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

[Tombik]

Не найдены свойства компонент. Версии другие?
мм... другие версии компонента? Или не может найти такие компоненты?

[ZdezBilYa]

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

[slesh]

2 Nightmarе Код под загрузке бинарника в буфер - это просто ужас.
1) Читает по 1 байту.
2) EOF - это эля текстовых файлов.

более правильнее былобы
такая последовательность функций
CreateFile (... GENERIC_READ ....)
size := GetFileSize(...)
setlength(buf, size);
ReadFile(... @buf[1], size, ....)
CloseFile();

т.е. ты открываешь файл на чтение. Получаешь его размер.
Под этот размер расширяешь строку, и сразу весь файл считываешь в неё.

[s0l_ir0n]

подскажите что за ошибки
Ты не установил компоненты.
1) Качаешь отсюда http://www.raize.com/DevTools/RzComps/RC5Trial.zip
2) Ставишь все по дефолту
3) Открываешь Delphi
4) Component -> Install Packages, Кнопка Add
5) Выбираешь C:\Program Files\Raize\RC5\Bin\RaizeComponentsTrialVcl_Design 70.bpl
6) Жмешь ОК, компоненты добавляются, радуешься жизни
:cool:

[mailbrush]

//решено :)

[Vlad3d]

Ты не установил компоненты.
1) Качаешь отсюда http://www.raize.com/DevTools/RzComps/RC5Trial.zip
2) Ставишь все по дефолту
3) Открываешь Delphi
4) Component -> Install Packages, Кнопка Add
5) Выбираешь C:\Program Files\Raize\RC5\Bin\RaizeComponentsTrialVcl_Design 70.bpl
6) Жмешь ОК, компоненты добавляются, радуешься жизни

http://i026.radikal.ru/0907/69/8b4ce52bdb38t.jpg (http://radikal.ru/F/i026.radikal.ru/0907/69/8b4ce52bdb38.jpg.html)
хммм

[ZdezBilYa]

хммм
по-моему, сообщает, что RaizeComponentsVd70 уже установлен (и возникает конфликт)
попробуй удалить установленную версию (удалить все пути и файлы), а потом установить эту

[Vlad3d]

по-моему, сообщает, что RaizeComponentsVd70 уже установлен (и возникает конфликт)
попробуй удалить установленную версию (удалить все пути и файлы), а потом установить эту
пробовал почему то опять появляются все те же 5 ошибок, что я выше выкладывал

[Nightmarе]

По поводу WinInet, если в параметрах прокси сервера в Internet Explorer находится невалидный прокси, то соответственно приложение на делфи через WinInet так-же не работает.
Можно ли это вообще как то исправить? чтобы не юзались настройки прокси в IE ?

Если да, то что тут подправить надо?
hOpenHandle := InternetOpen(nil, 0, nil, nil, 0);
if hOpenHandle <> nil then
begin
hConnectHandle := InternetConnect(hOpenHandle, szHost,80,nil,nil,3,0,0);
if hConnectHandle <> nil then
begin
hResourceHandle := HttpOpenRequest(hConnectHandle,'POST',szPath,nil,n il,nil,INTERNET_FLAG_KEEP_CONNECTION,0);
if hResourceHandle <> nil then
begin
HttpSendRequest(hResourceHandle,'Content-Type: application/x-www-form-urlencoded',47,szData,lstrlen(szData));

[Nullsleep]

var
proxy_info: PInternetProxyInfo;
begin
New(proxy_info);
proxy_info^.dwAccessType := INTERNET_OPEN_TYPE_DIRECT;
UrlMkSetSessionOption(INTERNET_OPTION_PROXY, proxy_info,
SizeOf(Internet_Proxy_Info), 0);
//здесь идет твой код
Dispose(proxy_info);
end;

[slesh]

Вообще эти настройки делаются сразу при открытии сесии

InternetOpen('BROWSER ID', INTERNET_OPEN_TYPE_PROXY, 'host:port', nil, 0);


INTERNET_OPEN_TYPE_DIRECT – обрабатывает все имена хостов локально.

INTERNET_OPEN_TYPE_PRECONFIG – берет установки из реестра.

INTERNET_OPEN_TYPE_PRECONFIG_WITH_NO_AUTOPROXY - берет установки из реестра и предотвращает запуск Jscript или Internet Setup (INS) файлов.

INTERNET_OPEN_TYPE_PROXY – использование прокси-сервера. В случае неудачи использует
INTERNET_OPEN_TYPE_DIRECT.

[НTL]

Использую компонент: IdHTTP Для передачи POST запроса

При ошибки 404 появляется масага с текстом об 404 ошибки и завершение обработки кода (Не выход из программы), как монжно сделать чтобы при 404 ошибки выполнялись определенные действия из обработчика?

[ZdezBilYa]

Использую компонент: IdHTTP Для передачи POST запроса

При ошибки 404 появляется масага с текстом об 404 ошибки и завершение обработки кода (Не выход из программы), как монжно сделать чтобы при 404 ошибки выполнялись определенные действия из обработчика?
try
<- POST-запрос
except
<- действия при ошибке
end;

[НTL]

try
<- POST-запрос
except
<- действия при ошибке
end;

Это работает, но масага все равно выскакивает

[slesh]

Если прога запускается под отладчиком (или из IDE делфового ), то полюбому будет выскакивать(потому как отладчик ловит эксепшены в первую очередь)
Ты запускай отдельно прогу лучше. Или если в отладчике, то просто продолжай выполнение

[НTL]

Если прога запускается под отладчиком (или из IDE делфового ), то полюбому будет выскакивать(потому как отладчик ловит эксепшены в первую очередь)
Ты запускай отдельно прогу лучше. Или если в отладчике, то просто продолжай выполнение

Я это знаю, и говорил я про уже скомпилированную прогу

[zeppe1in]

НTL
дак значит в компоненте эта месага

[mailbrush]

Прочитай синтаксис try ... except. В инди ексепшн вроде EIdHTTPProtocolException

[НTL]

Прочитай синтаксис try ... except. В инди ексепшн вроде EIdHTTPProtocolException

Не помогло, хотя я вроде убрал все строчки об масаги (С помощью "//")

[ex3me]

Получаю скрин активного окна таким образом:

procedure CaptureActiveWindow(_Bimap: TBitMap);
var
Im: TCanvas;
_scRect, _winRect: TRect;
hw: THandle;
begin
Im := TCanvas.Create;
Im.Handle := GetWindowDC(GetDesktopWindow);
hw := GetForeGroundWindow;
if hw <> 0 then
GetWindowRect(hw, _winRect);
try
_scRect := Rect(0, 0, _winRect.Right - _winRect.Left, _winRect.Bottom - _winRect.Top);
_Bimap.Width :=_winRect.Right - _winRect.Left;
_Bimap.Height := _winRect.Bottom -_winRect.Top;
_Bimap.Canvas.CopyRect(_scRect, Im, _winRect);
finally
ReleaseDC(0, Im.Handle);
Im.Free;
end;
end;

//заюзаем
procedure TForm1.Button1Click(Sender: TObject);
var
_Bmp:TBitmap;
begin
Sleep(500);
_Bmp:=TBitmap.Create;
CaptureActiveWindow(_Bmp);
_Bmp.SaveToFile('c:\pic.bmp');
_Bmp.Free;
end;

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

Position: 225, 132
Size: 102, 41

[W!z@rD]

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

Посмотри API PrintWindow

[mailbrush]

НTL,
try
body:=IdHTTP1.Get('http://site.com/script.php');
except
on EIdHTTPProtocolException do
begin
//Твой код
end;
end;

[НTL]

НTL,
try
body:=IdHTTP1.Get('http://site.com/script.php');
except
on EIdHTTPProtocolException do
begin
//Твой код
end;
end;



Работает но:
http://smages.com/i/8f/34/8f34ee4dc71c12a9db2e80bedb9ee86f.jpg

Все равно появляется, чтобы ево убрать надо в IdHTTP строчки убрать, но какие?

[mailbrush]

Закомментируй в IdHTTP.pas строчку, которая выделяется в дельфи при эксепшене.
raise что-то там...

[НTL]

Закомментируй в IdHTTP.pas строчку, которая выделяется в дельфи при эксепшене.
raise что-то там...

Знаеш скока там таких?

Давай так, если у тебя не выдает такую ошибку то ты мне скинешь свой idhttp.pas

[[n]-c0der]

Вы идиоты!(с) Dr. House
Нихрена там ниче коментить не надо!, Всего лишь надо try,except и все, ошибка вылетает в среде делфи(под отладчиком), просто скомпилируй запусти и не будет вылетать эксепшена...

[mailbrush]

[n]-c0der, я ему это говорил, но, видать, что-то не получается у него.

Знаеш скока там таких?Когда в дельфи открываешь прогу, отсылаешь запрос, дельфя при эксепшене октрывает IdHTTP.pas и выделяет строчку, которая генерит ошибку, вот ты и закомментируй её.

Давай так, если у тебя не выдает такую ошибку то ты мне скинешь свой idhttp.pasУ меня не выдает, использую метод, выложенный мною выше. Версии инди у нас могут быть разные.

[НTL]

-c0der']Вы идиоты!(с) Dr. House
Нихрена там ниче коментить не надо!, Всего лишь надо try,except и все, ошибка вылетает в среде делфи(под отладчиком), просто скомпилируй запусти и не будет вылетать эксепшена...

Думаеш самый умный? Читай тему

Когда в дельфи открываешь прогу, отсылаешь запрос, дельфя при эксепшене октрывает IdHTTP.pas и выделяет строчку, которая генерит ошибку, вот ты и закомментируй её.

У меня выделяет строчке в Unit1 которая отсылает ( RichEdit1.Lines.Text := UTF8ToAnsi(IdHTTP1.Get(Хост));)

У меня не выдает, использую метод, выложенный мною выше. Версии инди у нас могут быть разные.

В этом и дело что версии разные... вот я и заиспользую IdHTTP от другой версии... А еще лучше если скинеш всю папку Indy...

[zeppe1in]

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

[slesh]

как вариант -

var
s:string
d:dword;
begin
d:= dword(pointer(@s[1])^);
end;

т.е. цифровое представление первых 4- байт как 1 двойного слова.
диапазон начала может быть от 1 до length(s)-3
Ну или про суммируй все такие 4-ки байт.

[desTiny]

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

[zeppe1in]

slesh
спасибо так и сделаю.

[transserg]

привеит всем возник такой вопрос
как узнать по букве визическое имя диска? вчастности флеш =)
пробовал так

QueryDosDevice(PChar(Volume), @lpQuery[0], MAXCHAR);

в lpQuery будет строка типа

'\Device\Harddisk1\DP(1)0-0+9'

чтозначат чимволы после Harddisk1? да и прав ли я в том что '\\.\PHYSICALDRIVE1' = '\Device\Harddisk1\DP(1)0-0+9'? если да то почему бывает такая ошибка когда начинаю извлекать безопасно диск пиши F а он извлекает к примеру диск E все эти диски флеш да и потом через прогу немогу извлечить диск F!
вот код модуля где я извелкаю диски (USBFLASH)

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls,setupapi;
type
TForm1 = class(TForm)
Button1: TButton;
Edit1: TEdit;
Memo1: TMemo;
Button2: TButton;
Edit2: TEdit;
procedure Button1Click(Sender: TObject);
procedure OnDeviceChange(var Msg: TMessage); message WM_DEVICECHANGE;
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;
implementation

{$R *.dfm}

function IsUSBDevice(DevInst: DWORD): boolean;
var
IDLen: DWORD;
ID: PChar;
s:string;
begin
{'USBSTOR\DISK&VEN_&PROD_USB_FLASH_DRIVE&REV_34CH\196B09014EC7&0'}
result := false;
if (CM_Get_Device_ID_Size(IDLen, DevInst, 0) <> 0) or (IDLen = 0) then
begin
// exit;
end;

inc(IDLen);
ID := GetMemory(IDLen);
if ID = nil then
exit;
if (CM_Get_Device_ID(DevInst, PAnsichar(ID), IDLen, 0) <> 0) or (not CompareMem(ID, PChar('USBSTOR'), 7)) then
begin
s:=ID;
form1.memo1.Lines.Add(String(ID));
FreeMemory(ID);
exit;
end;
s:=ID;
form1.memo1.Lines.Add(String(ID));
FreeMemory(ID);
result := true;
end;

function GetDeviceName(PnPHandle: HDEVINFO; const DevData: TSPDevInfoData): string;
var
BytesReturned: DWORD;
RegDataType: DWORD;
Buffer: array [0..256] of CHAR;
begin
BytesReturned := 0;
RegDataType := 0;
Buffer[0] := #0;
SetupDiGetDeviceRegistryProperty(PnPHandle, DevData, SPDRP_FRIENDLYNAME,
RegDataType, PByte(@Buffer[0]), SizeOf(Buffer), BytesReturned);
Result := Buffer;
if Result<>'' then exit;
BytesReturned := 0;
RegDataType := 0;
Buffer[0] := #0;
SetupDiGetDeviceRegistryProperty(PnPHandle, DevData, SPDRP_DEVICEDESC,
RegDataType, PByte(@Buffer[0]), SizeOf(Buffer), BytesReturned);
Result:=Buffer;
end;

function DWORDtoDiskNames(val:DWORD):string;
var
_i: integer;
begin
Result:='';
for _i := 0 to 25 do
begin
if ((val mod 2)=1) then Result:=result+ chr(_i + 65);
val:=val shr 1;
end;
end;

procedure TForm1.Button2Click(Sender: TObject);
VAR
lpQuery: array [0..MAXCHAR - 1] of Char;
Volume,s:STRING;

begin
{'\\.\PHYSICALDRIVE1'}
Volume:=Edit1.text+':';
Volume[3] := #0;
QueryDosDevice(PChar(Volume), @lpQuery[0], MAXCHAR);
s:=lpQuery;
Volume:='';
Edit2.Text:=s;
{'\Device\Harddisk1\DP(1)0-0+9'}
end;
procedure TForm1.OnDeviceChange(var Msg: TMessage);
var
MSGSTR:String;
begin
if Msg.WParam=DBT_DEVICEARRIVAL then
begin
case PDEV_BROADCAST_HDR(Msg.LParam)^.dbch_devicetype of
DBT_DEVTYP_VOLUME:
begin
MSGSTR:='новый диск'+MSGSTR;
Edit1.Text:=(MSGSTR+' '+DWORDtoDiskNames(PDEV_BROADCAST_VOLUME(Msg.LPara m)^.dbcv_unitmask)+':');
end;
end;
end;
if Msg.WParam=DBT_DEVICEREMOVECOMPLETE then
begin
case PDEV_BROADCAST_HDR(Msg.LParam)^.dbch_devicetype of
DBT_DEVTYP_VOLUME:
begin
MSGSTR:='извлечён диск'+MSGSTR;
Edit1.Text:=(MSGSTR+' '+DWORDtoDiskNames(PDEV_BROADCAST_VOLUME(Msg.LPara m)^.dbcv_unitmask)+':');
end;
end;
end;
end;


procedure RemoveDrive(index:integer);
var
DrivesPnPHandle: HDEVINFO;
DevInfo: TSPDevInfoData;
Parent: DWORD;
s:string;
VetoName:array[0..MAX_PATH] of char;
begin
DevInfo.cbSize := sizeof(SP_DEVINFO_DATA);
DrivesPnPHandle := SetupDiGetClassDevsA(@GUID_DEVCLASS_DISKDRIVE, nil, 0, 2);
if DrivesPnPHandle = INVALID_HANDLE_VALUE then
exit;
if SetupDiEnumDeviceInfo(DrivesPnPHandle, index,DevInfo) then
begin
s:=GetDeviceName(DrivesPnPHandle,DevInfo);
if (IsUSBDevice(DevInfo.DevInst)) and (CM_Get_Parent(Parent, DevInfo.DevInst, 0) = CR_SUCCESS)
then
begin
CM_Request_Device_Eject(Parent, nil, nil{@VetoName}, {MAX_PATH}0, 0);
end
else
ShowMessage('Это не USB устройство');
end;
SetupDiDestroyDeviceInfoList(DrivesPnPHandle);
end;


procedure TForm1.Button1Click(Sender: TObject);
VAR
lpQuery: array [0..MAXCHAR - 1] of Char;
Volume,s:STRING;
begin
Volume:=Edit1.text+':';
Volume[3] := #0;
QueryDosDevice(PChar(Volume), @lpQuery[0], MAXCHAR);
s:=lpQuery;
Volume:='';
Memo1.Lines.add(s);
{'\Device\Harddisk1\DP(1)0-0+9'}
RemoveDrive(StrToInt(lpQuery[16]));
end;
end.

ткните носом в мои ошибки! если можно то с примерами исправления!

[ex3me]

slesh, по посту 4030 (http://forum.antichat.ru/showpost.php?p=1422081&postcount=4030) поможешь? Так и не осилил PrintWindow, чтобы получить скрин интересующего меня элемента на форме (координаты и размер известны)

[Nullsleep]

const
x = 225;
y = 132;
w = 102;
h = 41;
var
rc: TRect;
bmp: TBitmap;
dc: HDC;
wnd: HWND;
begin
bmp := TBitmap.Create;
bmp.Width := w;
bmp.Height := h;
wnd := GetForegroundWindow;
dc := GetDC(wnd);
BitBlt(bmp.Canvas.Handle, 0, 0, w, h, dc, x, y, SRCCOPY);
ReleaseDC(wnd, dc);
bmp.SaveToFile('screen.bmp');
bmp.Free;
end;

x,y - координаты элемента
w,h - ширина и высота

[.::[КОСТЕТ]::.]

Вводят 7е число нужно посчитать сумму двух последних цифр и если она бут равна 1й цифре то выдать труе.

[Nullsleep]

function Aga(num: Integer): Boolean;
var
s: string;
l: Integer;
begin
Result := False;
s := IntToStr(num);
l := Length(s);
if StrToInt(s[l])+StrToInt(s[l-1]) = StrToInt(s[1]) then
Result := True;
end;

[Nightmarе]

2 Nightmarе Код под загрузке бинарника в буфер - это просто ужас.
1) Читает по 1 байту.
2) EOF - это эля текстовых файлов.

более правильнее былобы
такая последовательность функций
CreateFile (... GENERIC_READ ....)
size := GetFileSize(...)
setlength(buf, size);
ReadFile(... @buf[1], size, ....)
CloseFile();

т.е. ты открываешь файл на чтение. Получаешь его размер.
Под этот размер расширяешь строку, и сразу весь файл считываешь в неё.

Если возможно то приведи плиз полный пример кода, а то хз как это юзать ;(

И ещё, эта функция тоже пихает весь файл в оперативку? если к примеру файл 100 метров

[.::[КОСТЕТ]::.]

СПАСИБО!

[slesh]

1 Nightmarе для больших файлов тебе нужно переписывать сам алгоритм отправки.
т.е. подгрузку реализовывать внутри самой функции отправки.
Но вообще лучше проверить размер файлов и если размер больше 64 кила.
ТО выделить буфер на 64 кила и читать пока читается и сразу отсылать.

[transserg]

Привет всем! запускаю программу с флешки и эта же программа должна извелч эту флешку но вот проблема!! будет ошибка так как запущенная прога не дает этого сделать! пробовал через Dll запустил процедуру из длл и убил прогу но тоже не проходит! как это можно исправить? нужно ли копировать длл на другой диск? или можно ее как то загрузить в память чтоб она не "зависела" от свой копии на диске?

[slesh]

1) получаешь адрес папка temp
2) копируеш туда прогу
3) запускаеш ту прогу передав к примеру путь откуда был ты запущен
4) завершаеш свою работу

Копия проги видя что в paramstr есть путь, ждет 1-2 секунды - чтобы дождаться завершения предыдущей копии, а дальше делает те действия которые должна делать.

[S[N]EP]

Привет всем у меня есть поле TEdit в котором написано parametr 142sds465, как 'Сказать' делфи чтобы он записал всё что после 'parametr ' в переменную?

[ZdezBilYa]

EP']Привет всем у меня есть поле TEdit в котором написано parametr 142sds465, как 'Сказать' делфи чтобы он записал всё что после 'parametr ' в переменную?
используй работу со строками:
например
Temp:=Copy(TEdit.Text,10,9);
ну если длина строки изменяется, то соответсвенно меняй второй и третий параметры

[ex3me]

S[N]EP, или так:

var
sPos: integer
temp: string;
begin
sPos := pos ( ' ', Edit1.Text );
if sPos <> 0 then temp := copy(Edti1.Text, sPos + 1, length ( Edit1.Text ) );
end;


Вообще так правильнее будет. Учитывая что у тебя строка формата "параметр код", ибо данный код ищет пробел

[transserg]

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

[.::[КОСТЕТ]::.]

upimg.ru нужно загрузить картинку программно и взять линк наскачивание как это сделать?

[slesh]

2 transserg тебе нужно все файлы который запускаются (exe + dll) скопировать во сременную папку и оттуда перезапустить. Просто в DLL должна быть функция которая отключает девайс по его пути. ну или типа того. для этого я и предлогаю передавать из первой проги во вторую адрес откуда запущена

[transserg]

slesh а что если сделть так, из ресурсов программы извеч маленький EXE а не копировать всю прогу целиком и запускать его с параметром, после запуска уже иничтожать его? да еще lkk может "жить" без пограммы которая ее заустила? тоесть выполнять свои функции и выгрузиться

[slesh]

може и так сделать. но DLL загружена до тех пор пока программа работает. после завершения работы проги DLL тоже выгружается. А если ты DLL загрузиш с флешки, то тогда ты отмантировать её несможеш до тех пор пока не выгрузиш DLL

[mailbrush]

Как в дельфи с помощью ресурсов (.res файлов) запустить программу из памяти (не копируя её куда-либо).

[ex3me]

Уважаемые знатоки! Имееются компоненты Image1 и Image2, в первом - картинка.

Внимание вопрос: как сделать копирование из Image1 в Image2 необходимой мне части картинки (условно - координаты: 100, 50 ; размер: 20х30)?

[Nullsleep]

const
x = 100;
y = 50;
w = 20;
h = 30;
x2 = 0;
y2 = 0;
begin
Image2.Canvas.CopyRect(Rect(x2, y2, w, h), Image1.Canvas,
Rect(x, y, w+x, h+y));
end;

x2, y2 - это координаты, определяющие куда нужно вставить часть изображения в Image2

[art2222]

Как в дельфи с помощью ресурсов (.res файлов) запустить программу из памяти (не копируя её куда-либо).

Создай в блокноте *.rc файл с таким текстом (например)

TESTFILE EXEFILE C:\Windows\Notepad.exe

Скомпилируй при помощи brcc32.exe в res файл.
Добавляешь такую строку в проект

{$R MYRES.RES}


И полный сорец

var
Form1: TForm1;
NOTEPAD_FILE: string;

implementation

{$R *.DFM}
{$R MYRES.RES}

function GetTempDir: string;
var
Buffer: array[0..MAX_PATH] of Char;
begin
GetTempPath(SizeOf(Buffer) - 1, Buffer);
Result := StrPas(Buffer);
end;

// Extract the Resource
function ExtractRes(ResType, ResName, ResNewName: string): Boolean;
var
Res: TResourceStream;
begin
Result := False;
Res := TResourceStream.Create(Hinstance, Resname, PChar(ResType));
try
Res.SavetoFile(ResNewName);
Result := True;
finally
Res.Free;
end;
end;

// Execute the file
procedure ShellExecute_AndWait(FileName: string);
var
exInfo: TShellExecuteInfo;
Ph: DWORD;
begin
FillChar(exInfo, SizeOf(exInfo), 0);
with exInfo do
begin
cbSize := SizeOf(exInfo);
fMask := SEE_MASK_NOCLOSEPROCESS or SEE_MASK_FLAG_DDEWAIT;
Wnd := GetActiveWindow();
ExInfo.lpVerb := 'open';
lpFile := PChar(FileName);
nShow := SW_SHOWNORMAL;
end;
if ShellExecuteEx(@exInfo) then
begin
Ph := exInfo.HProcess;
end
else
begin
ShowMessage(SysErrorMessage(GetLastError));
Exit;
end;
while WaitForSingleObject(ExInfo.hProcess, 50) <> WAIT_OBJECT_0 do
Application.ProcessMessages;
CloseHandle(Ph);
end;

// To Test it
procedure TForm1.Button1Click(Sender: TObject);
begin
if ExtractRes('EXEFILE', 'TESTFILE', NOTEPAD_FILE) then
if FileExists(NOTEPAD_FILE) then
begin
ShellExecute_AndWait(NOTEPAD_FILE);
ShowMessage('Notepad finished!');
DeleteFile(NOTEPAD_FILE);
end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
NOTEPAD_FILE := GetTempDir + 'Notepad_FROM_RES.EXE';
end;


Вроде бы вот так. После выполнения файл удалится.
Сорец не мой, к сожалению автора не знаю.

[mailbrush]

art2222, не надо меня учить как компилить с .rc в .res :)
И ответ у тебя не тру :)
Вчитайся в вопрос:
Как в дельфи с помощью ресурсов (.res файлов) запустить программу из памяти (не копируя её куда-либо).

[bons]

Как в дельфи с помощью ресурсов (.res файлов) запустить программу из памяти (не копируя её куда-либо).
http://www.wasm.ru/article.php?article=memfile
там правда пример на асме но разобраться надеюсь труда не составит
если программа в виде длл то тут slesh выкладывал https://forum.antichat.ru/threadnav132116-1-10.html. Хотя думаю при желании можно модифицировать и для exe

[transserg]

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

[Scripter]

Сервер

procedure TForm1.IdTCPServer1Connect(AThread: TIdPeerThread);
var
text: string;
begin
text := 'test';
AThread.Connection.ReadBuffer(Clientbuffer,SizeOf( Clientbuffer)); //читаем то что шлет клиент при подключении
Clientbuffer.login := AnsiLowerCase(Trim(Clientbuffer.Login)); //удаляем пробелы по краям и вводим в нижний регистр для сверки
if text = Clientbuffer.Login then //сверям
TidpeerThread(Athread).Connection.WriteLn('ok'); //если верно, отсылаем клиенту ОК
end;

procedure TForm1.IdTCPServer1Execute(AThread: TIdPeerThread);
var
Msg : String;
begin
Msg := AThread.Connection.ReadLn; //читаем значение
memo1.Lines.Add(Msg); //записываем значение
end;



Клиент

procedure TForm1.Button1Click(Sender: TObject);
begin
with SendBuffer do
begin
Login := edit11.text; //заполняем буфер данными перед отправкой
end;
idTCPclient1.Connect; //подключаемся
idTCPClient1.WriteBuffer(SendBuffer,SizeOf(SendBuf fer),true); //шлем данные

if idTCPclient1.ReadLn = 'ok' then //если ответ ОК то
begin
Memo1.Lines.Add(Подрубились); //пишем подрубились
button2.enabled := true; //делаем кнопку доступной
end;

procedure TForm1.Button2Click(Sender: TObject);
var
A : integer = 0;
begin
inc(A);
IdTCPClient1.writeln(intToStr(A)); //отсылаем значение А серверу
end;



Проблема: всё работает, но сервер не получает данные А и не записывает их, либо клиент не отсылает их, но это врядли.
В чем моя ошибка? Заранее спасибо.

[Nullsleep]

Scripter, попробуй перенести весь код из IdTCPServer1Connect в IdTCPServer1Execute.
И еще: почему бы вместо TidpeerThread(Athread).Connection.WriteLn('ok'); не написать просто Athread.Connection.WriteLn('ok');?

[Scripter]

Scripter, попробуй перенести весь код из IdTCPServer1Connect в IdTCPServer1Execute.
И еще: почему бы вместо TidpeerThread(Athread).Connection.WriteLn('ok'); не написать просто Athread.Connection.WriteLn('ok');?
спасибо попробую, а в коде у меян пишется именно так:
Athread.Connection.WriteLn('ok');
не знаю почему тут написал иначе :D

[Scripter]

Msg := AThread.Connection.ReadLn;
AThread.Connection.ReadBuffer(Clientbuffer,SizeOf( Clientbuffer));

засунул в execute на сервер, и клиент виснуть начал

[yfet]

нет соединения через idPop3((
Вобщем условие такое, есть список email-ов. Надо проверить, работают ли они. пишу такой код:

procedure Divide(Sourse:string;var Dest1,Dest2, Dest3:string);
begin
Dest1:=Copy(Sourse,1,Pos('@',Sourse)-1);//получаем имя пользователя
Dest3:=Copy(Sourse,1,Pos(';',Sourse)-1);
Delete(Sourse,1,Pos(';',Sourse));
Dest2:=Sourse; // получаем пароль
end;

procedure TMainForm.BitBtn1Click(Sender: TObject);
var
Dest1, Dest2, Dest3, pop : string;
ss : TStringList;
i:integer;
begin
if FileEdit.Text='' then begin
ShowMessage('Не загружен список!!!');
exit;
end else begin
ss:=TStringList.Create;
ss.LoadFromFile(FileEdit.Text);
ListBox1.Items.LoadFromFile(OpenDialog1.FileName);
for i:=0 to ss.Count-1 do begin
Divide(ss.Strings[i],Dest1,Dest2, Dest3);
pop:='pop.'+copy(Dest3, pos('@', Dest3)+1,10000);
IdPOP31.Host:=pop;
IdPOP31.Port:=110;
IdPOP31.Username:=Dest1;
IdPOP31.Password:=Dest2;
try
IdPOP31.Connect;
except
end;
if IdPOP31.Connected then
ListBox2.Items.Add(Dest1+':'+Dest2+' - Valid')
else
ListBox2.Items.Add(Dest1+':'+Dest2+' - Invalid') ;
end;
end;
ss.Free;
IdPop31.Disconnect;
end;

Пишет все время что Invalid хотя имя и пароль верные, и pop сервер указан верно. В чем я ошибся?

[ZdezBilYa]

Вот так у меня получилось:


for i:=0 to ss.Count-1 do
begin
Divide(ss.Strings[i],Dest1,Dest2, Dest3);
pop:='pop.'+copy(Dest3, pos('@', Dest3)+1,10000);
IdPOP31.Host:=pop;
IdPOP31.Port:=110;
IdPOP31.Username:=Dest1;
IdPOP31.Password:=Dest2;
try
IdPOP31.Connect;
ListBox2.Items.Add(Dest1+':'+Dest2+' - Valid')
except
ListBox2.Items.Add(Dest1+':'+Dest2+' - Invalid') ;
end;
IdPop31.Disconnect;
end;
ss.Free;

[ex3me]

Такого вопроса не нашел в разделе Кодинг, посему задам тут.

Как юзать хуки в делфи без использования DLL?

Конкретно интересует пример хука на отлов окон до их прорисовки на экране.

Нагуглил такой код:

Function WndHookProc(nCode:Integer;wParam:UINT;lParam:UINT) :LRESULT; stdcall;
begin
Wnd:=FindWindow(nil,PChar('Безымянный - Блокнот'));
if nCode>=0 then
if PCWPStruct(lParam).Message=WM_SHOWWINDOW then begin
// Работа с окном блокнота тут
end;
Result:=CallNextHookEx(HookHandle,nCode,wParam,lPa ram);
end;

Честно говоря - нифига непонятно =\ С хуками никогда не сталкивался. В гугле - примеры кейлоггера, но опять же: с помощью DLL.

Буду благодарен за любой пример хука на отлов окон (с DLL или без нее).

З.Ы. Greetz to Slesh & NullSleep за проявленное внимание на мои вопросы и оказанную помощь =)

[ErrorNeo]

ex3me
http://forum.antichat.ru/threadnav118323-1-10.html
http://forum.oszone.net/post-292753-27.html
http://www.wasm.ru/article.php?article=hiddndt
http://www.wasm.ru/publist.php?list=21
http://www.wasm.ru/article.php?article=apihook_3
http://www.programmersforum.ru/showthread.php?t=18&highlight=%F1%EA%F0%FB%F2%FC+%EF%F0%EE%F6%E5%F1%F1
http://www.programmersclub.ru/gruzin-api-perhvat/
http://www.vr-online.ru/review.php?id=63

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

[mailbrush]

Надо написать генератор рандумной строки из даных символов. Я сделал этоfunction SubStr(const Str: string; Start: Integer; Size: Word): string;
begin
SubStr := Copy(Str, Start, Size)
end;

function Rand(count,symbols: string): string;
var
i: integer;
begin
for i:=1 to StrToInt(count) do
begin
result:=result+SubStr(symbols,Random(Length(symbol s)),1);
Application.ProcessMessages;
end;
end;Но трабла в том, что генерит он не совсем рандумно. Пример: http://img44.imageshack.us/img44/7493/11637706.png
Я специально поставил только цифры, чтобы было лучше видно.
Как решить это?

[Nullsleep]

mailbrush, напиши в OnCreate строку:

Randomize;

И еще вместо твоей функции SubStr я бы написал так:

result:=result+symbols[Random(Length(symbols)-1)+1];

[Nullsleep]

Msg := AThread.Connection.ReadLn;
AThread.Connection.ReadBuffer(Clientbuffer,SizeOf( Clientbuffer));

засунул в execute на сервер, и клиент виснуть начал
Ты считываешь в Clientbuffer, размер которого нулевой. Тебе нужно отсылать размер Sendbuffer'а перед отправкой.
Перед idTCPClient1.WriteBuffer(SendBuffer,SizeOf(SendBuf fer),true);
в клиентской части тебе нужно написать:

idTCPClient1.WriteInteger(SizeOf(SendBuffer));

А в серверной изменить строку AThread.Connection.ReadBuffer(Clientbuffer,SizeOf( Clientbuffer));
на:

AThread.Connection.ReadBuffer(Clientbuffer, AThread.Connection.ReadInteger);

[transserg]

привет всем!
возникла сложность в обработке файлика на winapi нужно выделить строки! стандартными способами делфи нехочу делать!
пытаюсь сделать так

var
Size:cardinal;
mas:Array[0..65536] of char;
Config:array of string;

procedure ReadConfig;
var
re:^integer;
MyFile:integer;
begin
MyFile:= Integer(CreateFile(PChar('sittings.txt'), GENERIC_READ+GENERIC_WRITE,FILE_SHARE_READ+FILE_SH ARE_WRITE, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0));
GetMem(re,Sizeof(re));
size:=Getfilesize(MyFile,nil);
ReadFile(THandle(MyFile), mas, size, LongWord(re^), nil);
Closehandle(MyFile);
end;

{$R *.dfm}
Function PosEx(Const SubStr, S: String; Offset: Cardinal = 1): Integer;
var
I,X: Integer;
Len, LenSubStr: Integer;
begin
If Offset = 1 Then
Result := Pos(SubStr, S)
Else
begin
I := Offset;
LenSubStr := Length(SubStr);
Len := Length(S) - LenSubStr + 1;
While I <= Len Do
begin
If S[I] = SubStr[1] Then
begin
X := 1;
While (X < LenSubStr) And (S[I + X] = SubStr[X + 1]) Do
Inc(X);
If (X = LenSubStr) Then
begin
Result := I;
Exit;
End;
End;
Inc(I);
End;
Result := 0;
End;
End;

procedure ObrabConfig;
var
i,j:integer;
S:string;
begin
i:=1;
form1.Label2.Caption:=inttostr(Size);
while i<10771 do
begin
j:=posex(#13#10,mas,i);
S:=copy(mas,i,j);
i:=j+3;
j:=0;
Setlength(Config,high(Config)+2);
Config[high(Config)]:=S;
Form1.memo1.lines.Add(S);
Form1.Label1.Caption:=inttostr(i);
Application.ProcessMessages;
if i>=10771 then
showmessage('ok');
Sleep(50);
end;
end;


но он выводит первою строку норма а потом гонит всякий "шлак"
что я делаю не так?

[slesh]

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


var
my_int:integer;
my_str:array[0..255] of chat;
begin
my_int := GetPrivateProfileIntA('config', 'MY_INT_VAL', 20, 'c:\config.ini');
GetPrivateProfileStringA('config', 'MY_STR_VAL', 'defoult value', my_str, 256, 'config.ini');


где
config - название секции
MY_INT_VAL - название параметра
20 - дефолтовое значение если число
c:\config.ini - непосредственно файл
defoult value - дефолтовое значение если строка
256 - размер буфера.

конфиг - стандартного оформления
[config]
MY_INT_VAL = 10
MY_STR_VAL = hello

[transserg]

slesh нет конфиг это просто название файла =) да там настройки для программы моей в каждой строке несколько параметров в другой еще несколько вот и нужно выделить строки, по отдельности =)

[slesh]

а вообще для работы с конфигами есть ряд функций
Описание найдете в инете
GetPrivateProfileIntA
GetPrivateProfileStringA
GetPrivateProfileStructA
GetPrivateProfileSectionNamesA
GetPrivateProfileSectionA

WritePrivateProfileStringA
WritePrivateProfileSectionA
WritePrivateProfileStructA

[transserg]

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

[slesh]

ну если хочешь читать строки на Апи. то как вариант тогда такая алгоритм.
Считываешь в буфер к примеру 256 байт.
далее ищешь символ конца строки #10 или #13#10
Отнимаешь от размера считанных данных позицию этих символов (+/- 1)
и ставишь передвигаешь указатель в файле назад на это значение.

[slesh]

Вот навоял функцию для чтения строк из файла на Win API с поддержкой Win и nix форматов файла.


function ReadString(h:THANDLE; var s:string; max:integer):boolean;
var
buf:pchar;
rb:dword;
p:dword;
begin
result := false;
getmem(buf, max);
ReadFile(h, buf^, max, rb, nil);
if rb > 0 then
begin
result := true;
p := pos(#10, string(buf));
if p = 0 then // если последняя строка
begin
s := string(buf);
end
else
begin
if (p > 1) and (buf[p-2] = #13) then // если Win формат
begin
s := copy(buf, 0, p-2);
end
else // если NIX формат
begin
s := copy(buf, 0, p-1);
end;
SetFilePointer(h, p - rb, nil, FILE_CURRENT);
end;
end;
freemem(buf);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
h:THANDLE;
s:string;
x:integer;
const
MAX_LEN = 256;
begin
h := CreateFile('e:\test.txt', GENERIC_READ, FILE_SHARE_READ, nil, OPEN_EXISTING, 0, 0);
if h <> INVALID_HANDLE_VALUE then
begin
for x := 1 to 10 do
begin
if ReadString(h, s, MAX_LEN) then // читаем строку
begin // если считалась
memo1.Lines.Add('Строка ' + inttostr(x) + ' - ' + s);
end
else break; // прерывем цикл если нет больше строк
end;
CloseHandle(h);
end;
end;

[mcflash]

Люди кто нибудь знает Как написать на delphi7 код для отправки смс

[mcflash]

Люди кто нибудь знает Как написать на delphi7 код для отправки смс :confused: :confused:

[ZdezBilYa]

Люди кто нибудь знает Как написать на delphi7 код для отправки смс :confused: :confused:
можно через сайт оператора с вводом капчи, можно через e-mail-гейт (если у абонента подключен), можно через ICQ слать

[Kuzya]

Скажите пожалуйста кто-нибудь функцию замены подстроки в строке на Delphi 2009. Я знаю что в интернете полно исходников таких функций, но в 2009-ом точно должна быть своя встроенная.

[ZdezBilYa]

Скажите пожалуйста кто-нибудь функцию замены подстроки в строке на Delphi 2009. Я знаю что в интернете полно исходников таких функций, но в 2009-ом точно должна быть своя встроенная.
Pos + Delete + Insert

[mailbrush]

Скажите пожалуйста кто-нибудь функцию замены подстроки в строке на Delphi 2009. Я знаю что в интернете полно исходников таких функций, но в 2009-ом точно должна быть своя встроенная.
Да, есть встроенная - StringReplace();

ZdezBilYa, вчитайся в вопрос.

[mailbrush]

Надо написать генератор рандумной строки из даных символов. Я сделал этоfunction Rand(count,symbols: string): string;
var
i: integer;
begin
Randomize;
for i:=1 to StrToInt(count) do
begin
result:=result+symbols[Random(Length(symbols))]);
Application.ProcessMessages;
end;
end;Но трабла в том, что генерит он не совсем рандумно. Пример: http://img44.imageshack.us/img44/7493/11637706.png
Я специально поставил только цифры, чтобы было лучше видно.
Как решить это?
PS: Процедуру Randomize пробовал засовывать в OnCreate - не помогло.

[=Zeus=]

Вот простой примерчик, все работает на ура

procedure TForm1.Button1Click(Sender: TObject);
var s: string;
i: byte;
begin
caption:='';
Randomize;
s:='abcd';
for i:=1 to 10 do
caption:=caption+ s[Random(length(s))+1];
end;

Попробовал ваш пример у себя - тоже все нормально. незнаю, почему у вас такие результаты получились... Может он выполняеться по тайперу с интервалом 1 ?? Рандом ведь от времени зависит.
П.С. у вас в коде нужно +1 добавить в рандом. Без него длина строки разная каждый раз. Рандом ведь и 0 возвращяет, а в строке символа с индексом 0 нету.

[МongBa†]

mailbrush
Больше нагруз на систему но думаю должно сработать:function Rand(count,symbols: string): string;
var
i,rnd: integer;
begin
Randomize;
for i:=1 to StrToInt(count) do
begin
rnd:=(Random(Length(symbols))+1)*9;
while rnd>Length(symbols) do rnd-Random(Length(symbols));
result:=result+symbols[rnd];
Application.ProcessMessages;
end;
end;

[Nullsleep]

function Rand(const count: Integer; const symbols: string): string;
var
i: Integer;
begin
Result := '';
Randomize;
for i := 1 to count do
begin
Result := Result + symbols[Random(Length(symbols))+1];
Application.ProcessMessages;
end;
end;

это работает у меня нормально.
http://img406.imageshack.us/img406/2205/aga.png

[=Zeus=]

2 Nullsleep
Дык, это же то же самое, что я написал, только функция.

А вообще меня улыбнуло. Такая простая вещь на первый взгляд, но как ни странно за 3 года я ни разу не пользовался такой функцией =))
И еще. По-моему Application.ProcessMessages там никчему, функция итак быстро работает.

[Seregakz]

Как можноно с помощью wininet передать пост запросом бинарный файл на сервер??

[dos999]

Посмотри тут http://www.rsdn.ru/article/inet/wininet.xml вроде норм расписано про функции.

[Seregakz]

Посмотри тут http://www.rsdn.ru/article/inet/wininet.xml вроде норм расписано про функции.

Да и ещё там с++((
я 0 в нём!
уже пробовал передавать текстовые файлы оони норм передаются, а вот если гиф картингу или rar архив но нефика(
приведине пример народ оч нуна :)

[dos999]

вообще не приходит или приходит но кривой?
попробуй Content-Type изменить на
HttpSendRequest(hResourceHandle, 'Content-Type: application/vnd', 47, szData, lstrlen(szData));

[Seregakz]

вообще не приходит или приходит но кривой?
попробуй Content-Type изменить на
HttpSendRequest(hResourceHandle, 'Content-Type: application/vnd', 47, szData, lstrlen(szData));

да не приходит ибо отправляю таким методом, а этот метод ток тект отпрвляет) а бинарники никак:


procedure send(file:String);
var
szBuf: array [0..6000000] of Char;
begin

ZeroMemory(@szBuf, SizeOf(szBuf));
lstrcpy(szBuf, PChar('file='));
lstrcat(szBuf, ((GetFileData(PChar(file)))));
SendPOSTData(Host,
Path,
szBuf);

end;

[WereWolfV]

Всем привет. Пробую писать свой HTTP клиент на сокетах. Тестить решил на mail.ru, страницу принимает, POST запрос отправляет. Но на попытку авторизации выдает страницу 302. Снифал все со своего браузера (Opera 9.64) заголовки запросов списал с него. POST запросы у программы и браузера идентичные, но через браузер авторизируется, а через прогу получаю страницу 302.
Алгоритм тестирования: отправляю GET запрос на главную страницу mail.ru, получаю куки, вставляю эти куки в POST запрос с логином и паролем, отсылаю его. (куки полученые после GET вставляю вручную через TEdit)
Помогите, кто знает из-за чего не идет авторизация.
Вот код:
type
THTTPClientForm = class(TForm)
Memo1: TMemo;
Label1: TLabel;
URL: TLabel;
EdURL: TEdit;
Button1: TButton;
Edit3: TEdit;
Label4: TLabel;
Memo2: TMemo;
EditMpopl: TEdit;
EditMrcu: TEdit;
procedure Button1Click(Sender: TObject);
Function GetWEBpage(addr:string; Method:integer):TStringList;
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure EdURLKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
private
{ Private declarations }
public
{ Public declarations }
end;

var
HTTPClientForm: THTTPClientForm;
SendBuff:string;
POST:string;

implementation

uses unit2;

{$R *.dfm}

procedure THTTPClientForm.Button1Click(Sender: TObject);
begin
Memo1.Lines.Assign(GetWebPage(edURL.text, StrToInt(Edit3.Text)));
end;

Function THTTPClientForm.GetWEBPage;
var
localaddr : sockaddr_in;
iMode, iSize:integer;
rfds: TFDSET;
Buff: array [0..1024] of char;
stClient:TSocket;
testingserver, servername, portname:string;
timeout:TTimeVal;
begin

Result:=TStringList.Create;

stClient:=socket(AF_INET, SOCK_STREAM, 0);
if stClient=INVALID_SOCKET then
begin
messageBox(0, 'Ошибка инициализации сокета', 'Error', MB_OK);
exit;
end;

ServerName:='mail.ru';
PortName:='80';

localaddr.sin_addr:=LookUpName(servername);
localaddr.sin_family:=AF_INET;
localaddr.sin_port:=htons(StrToIntDef(portname, 80));

if connect(stClient, @localaddr, sizeof(localaddr))<>0 then
begin
messageBox(0, 'Ошибка соединения', 'Error', MB_OK);
exit;
end;

SendBuff:='';

if method=1 then
SendBuff:=
'GET / HTTP/1.1'#13+
'User-Agent: Opera/9.64 (Windows NT 5.1; U; ru) Presto/2.1.1'#13+
'Host: www.mail.ru'#13+
'Accept: text/html, application/xml;q=0.9, application/xhtml+xml, image/png, image/jpeg, image/gif, image/x-xbitmap, */*;q=0.1'#13+
'Accept-Language: ru-RU,ru;q=0.9,en;q=0.8'#13+
'Accept-Charset: iso-8859-1, utf-8, utf-16, *;q=0.1'#13+
'Accept-Encoding: deflate, gzip, x-gzip, identity, *;q=0'#13+
'If-Modified-Since: Fri, 14 Aug 2009 11:18:57 GMT'#13+
'Connection: Keep-Alive, TE'#13+
'TE: deflate, gzip, chunked, identity, trailers'#13#13;

if method=2 then
begin
POST:='Login=UserLogin+&Domain=mail.ru&Password=UserPassword';
SendBuff:=
'POST /cgi-bin/auth HTTP/1.1'#13+
'User-Agent: Opera/9.64 (Windows NT 5.1; U; ru) Presto/2.1.1'#13+
'Host: win.mail.ru'#13+
'Accept: text/html, application/xml;q=0.9, application/xhtml+xml, image/png, image/jpeg, image/gif, image/x-xbitmap, */*;q=0.1'#13+
'Accept-Language: ru-RU,ru;q=0.9,en;q=0.8'#13+
'Accept-Charset: iso-8859-1, utf-8, utf-16, *;q=0.1'#13+
'Accept-Encoding: deflate, gzip, x-gzip, identity, *;q=0'#13+
'Referer: http://www.mail.ru/'#13+
'Cookie: Mpopl='+EditMpopl.Text+'; mrcu='+EditMrcu.Text+';'#13+
'Cookie2: $Version=1'#13+
'Connection: Keep-Alive, TE'#13+
'TE: deflate, gzip, chunked, identity, trailers'#13+
'Content-Length: '+IntToStr(Length(POST))+#13+
'Content-Type: application/x-www-form-urlencoded'#13#13+POST;
end;

Memo2.Lines.Clear;
Memo2.Lines.Add(SendBuff);
SendStr(stClient,SendBuff);

iMode:=1;
setsockopt(stClient, IPPROTO_TCP, TCP_NODELAY, @iMode, sizeof(integer));

while true do
begin
FD_ZERO(rfds);
FD_SET(stClient, rfds);

timeout.tv_sec:=10;
if (select(0, @rfds, nil, nil, @timeout)<=0) then
exit;

if (FD_ISSET(stClient, rfds)) then
begin
iSize:=recv(stClient, buff, sizeof(buff), 0);
if (iSize<1) then
break;
Result.Add(String(buff));
end;
end;
CloseSocket(stClient);
end;

procedure THTTPClientForm.FormCreate(Sender: TObject);
var SockInit:TWSADATA;
begin
WSAStartUp(makeword(2,0), SockInit)
end;

[login999]

Всем привет. Пробую писать свой HTTP клиент на сокетах. Тестить решил на mail.ru, страницу принимает, POST запрос отправляет. Но на попытку авторизации выдает страницу 302. Снифал все со своего браузера (Opera 9.64) заголовки запросов списал с него. POST запросы у программы и браузера идентичные, но через браузер авторизируется, а через прогу получаю страницу 302.
Алгоритм тестирования: отправляю GET запрос на главную страницу mail.ru, получаю куки, вставляю эти куки в POST запрос с логином и паролем, отсылаю его. (куки полученые после GET вставляю вручную через TEdit)
Помогите, кто знает из-за чего не идет авторизация.
Вот код:
type
THTTPClientForm = class(TForm)
Memo1: TMemo;
Label1: TLabel;
URL: TLabel;
EdURL: TEdit;
Button1: TButton;
Edit3: TEdit;
Label4: TLabel;
Memo2: TMemo;
EditMpopl: TEdit;
EditMrcu: TEdit;
procedure Button1Click(Sender: TObject);
Function GetWEBpage(addr:string; Method:integer):TStringList;
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure EdURLKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
private
{ Private declarations }
public
{ Public declarations }
end;

var
HTTPClientForm: THTTPClientForm;
SendBuff:string;
POST:string;

implementation

uses unit2;

{$R *.dfm}

procedure THTTPClientForm.Button1Click(Sender: TObject);
begin
Memo1.Lines.Assign(GetWebPage(edURL.text, StrToInt(Edit3.Text)));
end;

Function THTTPClientForm.GetWEBPage;
var
localaddr : sockaddr_in;
iMode, iSize:integer;
rfds: TFDSET;
Buff: array [0..1024] of char;
stClient:TSocket;
testingserver, servername, portname:string;
timeout:TTimeVal;
begin

Result:=TStringList.Create;

stClient:=socket(AF_INET, SOCK_STREAM, 0);
if stClient=INVALID_SOCKET then
begin
messageBox(0, 'Ошибка инициализации сокета', 'Error', MB_OK);
exit;
end;

ServerName:='mail.ru';
PortName:='80';

localaddr.sin_addr:=LookUpName(servername);
localaddr.sin_family:=AF_INET;
localaddr.sin_port:=htons(StrToIntDef(portname, 80));

if connect(stClient, @localaddr, sizeof(localaddr))<>0 then
begin
messageBox(0, 'Ошибка соединения', 'Error', MB_OK);
exit;
end;

SendBuff:='';

if method=1 then
SendBuff:=
'GET / HTTP/1.1'#13+
'User-Agent: Opera/9.64 (Windows NT 5.1; U; ru) Presto/2.1.1'#13+
'Host: www.mail.ru'#13+
'Accept: text/html, application/xml;q=0.9, application/xhtml+xml, image/png, image/jpeg, image/gif, image/x-xbitmap, */*;q=0.1'#13+
'Accept-Language: ru-RU,ru;q=0.9,en;q=0.8'#13+
'Accept-Charset: iso-8859-1, utf-8, utf-16, *;q=0.1'#13+
'Accept-Encoding: deflate, gzip, x-gzip, identity, *;q=0'#13+
'If-Modified-Since: Fri, 14 Aug 2009 11:18:57 GMT'#13+
'Connection: Keep-Alive, TE'#13+
'TE: deflate, gzip, chunked, identity, trailers'#13#13;

if method=2 then
begin
POST:='Login=UserLogin+&Domain=mail.ru&Password=UserPassword';
SendBuff:=
'POST /cgi-bin/auth HTTP/1.1'#13+
'User-Agent: Opera/9.64 (Windows NT 5.1; U; ru) Presto/2.1.1'#13+
'Host: win.mail.ru'#13+
'Accept: text/html, application/xml;q=0.9, application/xhtml+xml, image/png, image/jpeg, image/gif, image/x-xbitmap, */*;q=0.1'#13+
'Accept-Language: ru-RU,ru;q=0.9,en;q=0.8'#13+
'Accept-Charset: iso-8859-1, utf-8, utf-16, *;q=0.1'#13+
'Accept-Encoding: deflate, gzip, x-gzip, identity, *;q=0'#13+
'Referer: http://www.mail.ru/'#13+
'Cookie: Mpopl='+EditMpopl.Text+'; mrcu='+EditMrcu.Text+';'#13+
'Cookie2: $Version=1'#13+
'Connection: Keep-Alive, TE'#13+
'TE: deflate, gzip, chunked, identity, trailers'#13+
'Content-Length: '+IntToStr(Length(POST))+#13+
'Content-Type: application/x-www-form-urlencoded'#13#13+POST;
end;

Memo2.Lines.Clear;
Memo2.Lines.Add(SendBuff);
SendStr(stClient,SendBuff);

iMode:=1;
setsockopt(stClient, IPPROTO_TCP, TCP_NODELAY, @iMode, sizeof(integer));

while true do
begin
FD_ZERO(rfds);
FD_SET(stClient, rfds);

timeout.tv_sec:=10;
if (select(0, @rfds, nil, nil, @timeout)<=0) then
exit;

if (FD_ISSET(stClient, rfds)) then
begin
iSize:=recv(stClient, buff, sizeof(buff), 0);
if (iSize<1) then
break;
Result.Add(String(buff));
end;
end;
CloseSocket(stClient);
end;

procedure THTTPClientForm.FormCreate(Sender: TObject);
var SockInit:TWSADATA;
begin
WSAStartUp(makeword(2,0), SockInit)
end;
Хз как там в дельфях, но 302 это редирект, маилру после авторизации редиректит... Так что походу все ок

[WereWolfV]

забыл написать, редиректит на http://win.mail.ru/cgi-bin/auth а при правильной авторизации должно на что-то подобное http://win.mail.ru/cgi-bin/checkcookie?id=4f06025a64445b73190502199a1d00071c0 c014f6a5d5e465e07070802051e0b03031e4e5c4a54475e5b5 341145c555e551f4243
и после на страницу пользователя.

[sadfeel]

Как найти вложение текста в строке не учитывая регистр..? Делал через Pos но там регистр учитывается. помогите плиз. Работаю в дeлфи

[W!z@rD]

s, s1: string;
begin
s:='ТекстТут';
s1:=LowerCase(s); //тесттут

вот и все...

[Nullsleep]

var
substr, s: string;
p: Integer;
begin
substr := 'b';
s := 'ABCD';
p := Pos(LowerCase(substr), LowerCase(s));
end;

[bons]

Как найти вложение текста в строке не учитывая регистр..? Делал через Pos но там регистр учитывается. помогите плиз. Работаю в дeлфи
из модуля strutils
function AnsiContainsText(const AText, ASubText: string): Boolean;

[xmadstyle]

Народ подскажите плиз как в дельфи работать с активными соединениями, а именно получить список активных соединений, ip и port источника и получателя определенного соединения, закрытие соединения.
Заранее спс.

[bons]

запускай netstat и анализируй его вывод
или если вручную
http://www.xakep.ru/magazine/xa/098/122/1.asp

[anticmc]

люди помогите пожалуйста. в программе есть кнопка. после её нажатия открывается окно браузера и сайт. мне нужно поменять этот сайт. так вот проблема в том что Resource Builder не показывает обработчик OnClick ни одной кнопки. просто примерно вот такой текст каждой кнопки.

object btnpay: TButton
Left = 129
Top = 129
Width = 67
Height = 25
Caption = 'Pay'
TabOrder = 5
Visible = False
OnClick = btnpayClick

а где находится обработчик? все обыскал!
Помогите кто знает. я в pascal ни бум бум.

[SuX]

I will use a translater to tell you what i want:
Может ли кто-нибудь сказать мне, как использовать половину жизни разорвать запросы? с Delphi?
Я хочу, чтобы игрок, и их имена frags.

http://developer.valvesoftware.com/wiki/Server_Queries

english:
Can someone tell me how to use half life sever queries ? with delphi ?
I want to get player names and their frags.
name - frags - deads

http://developer.valvesoftware.com/wiki/Server_Queries

I need a simple code, i use delphi 7 :)

[Nullsleep]

anticmc: Если строка, содержащая url, не зашифрована, то можно открыть программу HEX-редактором и попробывать там найти и заменить URL.
А обработчик события на паскале ты никогда не найдешь, потому что этот код компилируется в машинный.

[anticmc]

anticmc: Если строка, содержащая url, не зашифрована, то можно открыть программу HEX-редактором и попробывать там найти и заменить URL.
А обработчик события на паскале ты никогда не найдешь, потому что этот код компилируется в машинный.


спасибо. разобрался!)

[cremator (c)]

anticmc, мне так показалось, что речь идёт о Delphi? Берёшь DeDe(Delphi decompilator), грузишь в него свой exe-шник. Декомпилируешь. И там найдёшь на вкладке Procedures все обработчики(в машинном коде, естественно)

[НTL]

вопрос нуба но все же:

Есть код

While......
begin
if ...... then
begin
Что здесь надо поставить чтобы выполнение While "Повторилось"???
end;
end;

Команда "End;" не подходит т.к. обработчик начинает ругаться на большое кол-во End-ов...

[Flenov]

Привет всем, кто меня читает.
Прошу мне немножко помоч.

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

Поясню:
var
F: TextFile;
S: String;
begin
AssignFile(F, 'MyTextFile.txt'); //Связываем файловую переменную с файлом
{$I-} //Отключаем сообщения об ошибках
Reset(F); //Открываю файл для чтения (Позиция равна нулю)
Readln(F, S); //Читаю первую строку (Позиция изменлась)
Flush(F); //Освобождаю память (Не уверен, что это нужно делать при чтении,
если кто знает поясните)
Closefile(F); //Закрываю файл
end;

[ZdezBilYa]

Что здесь надо поставить чтобы выполнение While "Повторилось"???

а что у тебя в условии While стоит? сделай, чтоб было True и всё повторится


Мне нужно в определённый момент вернуть курсор на нулевую позицию, незакрывая файл.

по-моему с текстовым файлом это не сделать. только типизированный или нетипизированный

Flush(F); //Освобождаю память (Не уверен, что это нужно делать при чтении,
если кто знает поясните)

при чтении не надо (она записывает файл)

[НTL]

а что у тебя в условии While стоит? сделай, чтоб было True и всё повторится



по-моему с текстовым файлом это не сделать. только типизированный или нетипизированный


при чтении не надо (она записывает файл)

while Memo1.Lines.Count > 0 do

Я не уверен что "Истина" тут подойдет

[ZdezBilYa]

while Memo1.Lines.Count > 0 do

Я не уверен что "Истина" тут подойдет
поставь переменную, например


temp:=Memo1.Lines.Count;
while temp> 0 do

а там уже оперируй ей

[cremator (c)]

НTL, вообще есть операторы прерывания и продолжения цикла.
break - выход из цикла
continue - переход к следующей итерации цикла
Вообще напиши весь код, а то как то непонятно какую цель ты преследуешь здесь.
Если ты удаляешь в цикле по строке из Memo и хочешь чтобы программа, когда число строк станет=0 удалила ещё одну строку, то тебе выдаст Access violation
Как вариант добавить доп. переменную

[=Zeus=]

поставь переменную, например


temp:=Memo1.Lines.Count;
while temp> 0 do

а там уже оперируй ей
Ты что, шутишь? это же безконечный цыкл! Например у мемо 2 строчки, и что тогда? Условие всегда верно, 2 всегда больше 0. Прога зависнет если break не делать в коде.

[mailbrush]

=Zeus=, вчитайся в слова а там уже оперируй ей
Вот пример кода, который выполнится 2 раза, если у тебя две строчки:
temp:=Memo1.Lines.Count;
while temp> 0 do
temp:=temp-1;

[=Zeus=]

temp:=Memo1.Lines.Count;
while temp> 0 do
temp:=temp-1;


А ну если так то конечно, тут без вопросов.

[Flenov]

Буду краток:

procedure ExtractIcons(FileName: String);
var
Image: TIcon;
Icon: HICON;
i, iSize: Integer;
begin
Image:=TIcon.Create;
try
iSize:=ExtractIconEx(PChar(FileName), -1, Icon, Icon, 0);
if (iSize=0) then Exit;
for i:=0 to iSize-1 do
begin
Image.Handle:=ExtractIcon(HInstance, PChar(FileName), i);
Image.SaveToFile('Icon'+'('+IntToStr(i+1)+')'+'.ic o');
end;
finally
Image.Free;
end;
end;

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

[De-visible]

Попробуй помолиться...

[cremator (c)]

Flenov, PC_Icon_Extractor_4.1_Portable в руки. Извлекает все иконки из любых файлов, будь то dll, exe etc.

А по существу, то надо было сделать так:

unit extracticons;

interface

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

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

var
Form1: TForm1;

type ThIconArray = array[0..0] of hIcon;
type PhIconArray = ^ThIconArray;

function ExtractIconEx(lpszFile: PAnsiChar;
nIconIndex: Integer;
phiconLarge : PhIconArray;
phiconSmall: PhIconArray;
nIcons: UINT): UINT; stdcall;
external 'shell32.dll' name 'ExtractIconExA';

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
var
NumIcons: integer;
pTheLargeIcons: phIconArray;
pTheSmallIcons: phIconArray;
LargeIconWidth,LargeIconHeight,
SmallIconWidth,SmallIconHeight: integer;
i: integer;
TheIcon: TIcon;
TheBitmap: TBitmap;
begin
NumIcons := ExtractIconEx('D:\system.dll',-1, nil, nil, 0);
if NumIcons > 0 then
begin
LargeIconWidth := GetSystemMetrics(SM_CXICON);
LargeIconHeight := GetSystemMetrics(SM_CYICON);
SmallIconWidth := GetSystemMetrics(SM_CXSMICON);
SmallIconHeight := GetSystemMetrics(SM_CYSMICON);
GetMem(pTheLargeIcons, NumIcons * sizeof(hIcon));
GetMem(pTheSmallIcons, NumIcons * sizeof(hIcon));
FillChar(pTheLargeIcons^, NumIcons * sizeof(hIcon), #0);
FillChar(pTheSmallIcons^, NumIcons * sizeof(hIcon), #0);
ExtractIconEx('D:\system.dll',0, pTheLargeIcons, pTheSmallIcons, numIcons);
{$IFOPT R+}
{$DEFINE CKRANGE}
{$R-}
{$ENDIF}
for i := 0 to (NumIcons - 1) do
begin
TheIcon := TIcon. Create;
TheBitmap := TBitmap.Create;
TheIcon.Handle := pTheLargeIcons^[i];
TheBitmap.Width := LargeIconWidth;
TheBitmap.Height := LargeIconHeight;
TheBitmap.Canvas.Draw(0, 0, TheIcon);
TheIcon.Free;
TheBitmap.SaveToFile('D:\ic\l'+inttostr(i)+'.ico') ;
TheBitmap.Free;


TheIcon := TIcon. Create;
TheBitmap := TBitmap.Create;
TheIcon.Handle := pTheSmallIcons^[i];
TheBitmap.Width := SmallIconWidth ;
TheBitmap.Height := SmallIconHeight;
TheBitmap.Canvas.Draw(0, 0, TheIcon);
TheIcon.Free;
TheBitmap.SaveToFile('D:\ic\s'+inttostr(i)+'.ico') ;
TheBitmap.Free;
end;
{$IFDEF CKRANGE}
{$UNDEF CKRANGE}
{$R+}
{$ENDIF}
FreeMem(pTheLargeIcons, NumIcons * sizeof(hIcon));
FreeMem(pTheSmallIcons, NumIcons * sizeof(hIcon));
end;

end;

end.


Конечно это не идеальный вариант, программа извлекает иконку в двух размерах 32х32 и 16х16, можешь оставить то, что тебе надо.

[НTL]

Как при помощи IdHTTP получить куки при авторизации на сайте Post запросом, а потом их отправить вместе с другим пост запросом???

[cremator (c)]

Вот пример авторизации в LJ

procedure TForm1.Button1Click(Sender: TObject);
var
Http : TidHttp;
CM : TidCookieManager;
Data : TStringList;
StrPage, UserID, UserName : String;
i : integer;
begin
try
Http := TIdHTTP.Create(Self);
Data := TStringList.Create;
CM := TidCookieManager.Create(Http);
Http.AllowCookies := true;
Http.CookieManager := CM;
Http.HandleRedirects := true;

Http.Request.Host:='livejournal.com';
Http.Request.UserAgent:='Mozilla/5.0 (Windows; U; Windows NT 5.1; ru; rv:1.9.0.10) Gecko/2009042316 Firefox/3.0.10';
Http.Request.Accept:='text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8';
Http.Request.AcceptLanguage:='ru,en-us;q=0.7,en;q=0.3';
Http.Request.AcceptCharSet:='windows-1251,utf-8;q=0.7,*;q=0.7';
Http.Request.Referer:='http://www.livejournal.com/';

Data.Add('mode=login');
Data.Add('user=Qwerty');
Data.Add('password=PASS');
StrPage := Http.Post('http://www.livejournal.com/login.bml?ret=1', Data);
finally
Data.Free;
CM.Free;
Http.Free;
end;

if Pos('<input class="logoutlj_hidden" id="user" name="user" type="hidden" value="'+Qwerty,StrPage) <> 0 then
ShowMessage('Авторизация прошла успешно')
else
ShowMessage('Авторизация провалилась');

Memo1.Lines.Text := StrPage;
end;



Возвращенные заголовки (после ответа сервера) можно посмотреть так:

idHttp.Response.RawHeaders.GetText;


Сохраненные в CookieManager-е кукисы можно посмотреть так:

for i := 0 to Http.CookieManager.CookieCollection.Count - 1 do
StrPage := StrPage + CM.CookieCollection.Items[i].CookieText + #13#10;

[НTL]

cremator (c), ну вот я авторизировался, получил куки, а как эти куки передать в другом пост запросе, что-то до меня не дошло

[cremator (c)]

Эти куку сохраняет сам IdHttp. Http.AllowCookies := true; - значит все последующие запросы будут уходить с этими куками, которые он получил

[s.p.a.m]

Как мне с помощью indy зайти на сайт со своими куками?

[НTL]

Эти куку сохраняет сам IdHttp. Http.AllowCookies := true; - значит все последующие запросы будут уходить с этими куками, которые он получил

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, IdCookieManager, IdBaseComponent, IdComponent,
IdTCPConnection, IdTCPClient, IdHTTP, ComCtrls;

type
TForm1 = class(TForm)
IdHTTP1: TIdHTTP;
IdCookieManager1: TIdCookieManager;
Button1: TButton;
Memo1: TMemo;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
var
Http : TidHttp;
CM : TidCookieManager;
Data, params : TStringList;
StrPage, UserID, UserName : String;
i : integer;
begin
try
Http := TIdHTTP.Create(Self);
Data:= TStringList.Create;
CM := TidCookieManager.Create(Http);
Http.AllowCookies := true;
Http.CookieManager := CM;
Http.HandleRedirects := true;

Http.Request.Host:=' testhtl.ucoz.ru';
Http.Request.UserAgent:='Mozilla/5.0 (Windows; U; Windows NT 5.1; ru; rv:1.9.0.10) Gecko/2009042316 Firefox/3.0.10';
Http.Request.Accept:='text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8';
Http.Request.AcceptLanguage:='ru,en-us;q=0.7,en;q=0.3';
Http.Request.AcceptCharSet:='windows-1251,utf-8;q=0.7,*;q=0.7';
Http.Request.Referer:='http://testhtl.ucoz.ru/';

Data.Add('user=qqq');
Data.Add('password=123456');
Data.Add('a=2');
StrPage := Http.Post('http://testhtl.ucoz.ru/index/sub/', Data);

params:=TStringList.Create;
params.Add(AnsiToUTF8('uname=ывапыва'));
params.Add(AnsiToUTF8('message=ывпыва'));
params.Add(AnsiToUTF8('url=ваыпыва'));
params.Add('s=566012520275405242056');
params.Add('a=8');
IdHTTP1.Post('http://testhtl.ucoz.ru/mchat/', params);
finally
Data.Free;
CM.Free;
Http.Free;
end;
Memo1.Lines.Text := StrPage;
end;

end.

Пост уходит без куков, в IdHTTP куки включёны, если бы куки в посте уходили то имя в чате было бы кликабельным

( Если сообщения в чате не добавляются то надо обновить s=566012520275405242056 , из исходнова кода странички http://testhtl.ucoz.ru/mchat/ )

[cremator (c)]

Что-то ты всё понаперепутал:D
Куки у тебя сохранились в Http, а запрос ты делаешь через новый(с формы, одного TIdHttp показалось мало?))) IdHTTP1, в котором от родясь куков не было))

[НTL]

Что-то ты всё понаперепутал:D
Куки у тебя сохранились в Http, а запрос ты делаешь через новый(с формы, одного TIdHttp показалось мало?))) IdHTTP1, в котором от родясь куков не было))

Даже при замене на Http.Post('http://testhtl.ucoz.ru/mchat/', params);
Куки не уходят

[cremator (c)]

Вся проблема в корявых индейцах.. Они не принимают печеньки этого сайта..! После 2х часового исследования так и не понял в чём дело:D

[Flenov]

Вся проблема в корявых индейцах.. Они не принимают печеньки этого сайта..! После 2х часового исследования так и не понял в чём дело:D

Ты охуенно прав.
Поэтому реальные перцы делают всё чере сокеты.

[slesh]

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

[BlackSilver]

Вопрос
При создании пытаюсь поменять свойство панели pCover.Align вот так
pCover.Align := alClient;
При компиляции выдаёт ошибку "Incompatible types: 'Controls.TAlign' and 'uDocsReg.TAlign'". uDocsReg - это модуль, в котором строка.
И, да, TAlign я нигде не обьявлял.

[cremator (c)]

Возможно ты переопределил тип TAlign в своём модуле.. Кинь весь код, так не разобраться

[slesh]

в файле Сontrols.pas описан этот тип
TAlign = (alNone, alTop, alBottom, alLeft, alRight, alClient, alCustom);
так что попробуй явно описать откуда брать
pCover.Align := Controls.alClient;
или
pCover.Align := uDocsReg.alClient;

[Flenov]

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


А реально какая альтернатива Индюкам?
Ну WinInet ещё можно попробовать, но там лажа с таймаутом.
Кстати, а WinInet зависит от FrameWork-а?
Или каким мокаром можно ФреймВорк заюзать из Делфы 7?

[slesh]

Есть разные компоненты связанные с HTTP
WinInet - пашет везде. Потому что это стандартная либа, которую придумали тогда когда фреймворка еще в задумках небыло.
Delphi 7 - FW - врядли. Для этих целей есть BDS. Хотя вроде с D8 уже тянется FW

[BlackSilver]

2cremator:
Внимательнее читай последнее предложение.

unit uDocsReg;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ComCtrls, cxGraphics, cxCustomData, cxStyles, cxTL, cxTextEdit,
cxInplaceContainer, cxControls, uDocsTreeMan, StdCtrls, ShlObj, QControls,
cxShellCommon, cxContainer, cxShellListView, cxListView, cxMCListBox,
cxEdit, cxCurrencyEdit, cxMaskEdit, cxSpinEdit, cxTimeEdit, uDBRecordsMan,
cxDropDownEdit, cxCalendar, ExtCtrls, cxLabel, uObjOperationObject,
uNewObjOperation, uConfig, Buttons, uFrDoc;

type
TfDocsReg = class(TForm)
bRefresh: TButton;
DocsTree: TTreeView;
pEdit: TPanel;
bUpdate: TButton;
cxLabel2: TcxLabel;
bAdd: TButton;
bDelete: TButton;
frDoc: TfrDoc;
pCover: TPanel;
pObject: TPanel;
lCoef: TcxLabel;
cxLabel1: TcxLabel;
cxLabel3: TcxLabel;
cxLabel4: TcxLabel;
procedure bRefreshClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure DocsTreeClick(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure bUpdateClick(Sender: TObject);
procedure bAddClick(Sender: TObject);
procedure bDeleteClick(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure bCalcCostClick(Sender: TObject);
private
{ Private declarations }
procedure LoadEdits;
procedure SetPanelEnabled( PanelNum: integer );

public
{ Public declarations }
procedure ShowDocs(FilterObjId: integer=-1);
procedure ClearActiveOperation;

end;

var
fDocsReg: TfDocsReg;

implementation

{$R *.dfm}

procedure TfDocsReg.bRefreshClick(Sender: TObject);
begin
DocsTreeMan.Refresh;
end;

procedure TfDocsReg.FormCreate(Sender: TObject);
begin
DocsTreeMan := TDocsTreeMan.Create(DocsTree);
ClearActiveOperation;
//pCover.Align := alClient;
//pObject.Align := alClient;
end;

procedure TfDocsReg.DocsTreeClick(Sender: TObject);
begin
DBRecords.Release( frDoc.ActiveItem );
frDoc.ActiveItem := DocsTreeMan.ActiveOperation;

if frDoc.ActiveItem <> nil then
SetPanelEnabled( 1 )
else
SetPanelEnabled( 0 );
end;

procedure TfDocsReg.FormClose(Sender: TObject; var Action: TCloseAction);
begin
DBRecords.Release( frDoc.ActiveItem );
SavePosition(self);
end;

procedure TfDocsReg.bUpdateClick(Sender: TObject);
Var NewId: integer;
begin
frDoc.SaveEdits;
if frDoc.ActiveItem.IsNew then
begin
NewId := frDoc.ActiveItem.Insert;
DBRecords.Release( frDoc.ActiveItem );
ClearActiveOperation;
DocsTreeMan.Refresh;
DocsTreeMan.SelectNode( NewId );
frDoc.ActiveItem := DBRecords.TakeObjOperation( NewId );
SetPanelEnabled( 1 );
end else
begin
frDoc.ActiveItem.Update;
DocsTreeMan.Refresh;
DocsTreeMan.SelectNode( frDoc.ActiveItem.id );
end;
end;

procedure TfDocsReg.bAddClick(Sender: TObject);
var NewOperation: TObjOperation;
begin
if (frDoc.ActiveItem <> nil) and
(frDoc.ActiveItem.id = -1) then
begin
DBRecords.Release( frDoc.ActiveItem );
ClearActiveOperation;
end;
NewOperation := TObjOperation.New;
if fNewObjOperation.ShowModal = mrOk then
begin
if (fNewObjOperation.cbDocs.EditValue = Null) or
(fNewObjOperation.cbObjects.EditValue = Null) then
begin
Beep;
NewOperation.Free;
Exit;
end;
NewOperation.SetField('id_doc', fNewObjOperation.cbDocs.EditValue);
NewOperation.SetField('id_object', fNewObjOperation.cbObjects.EditValue);
DBRecords.Release( frDoc.ActiveItem );
DBRecords.ObjOperations.Add( Pointer( NewOperation.id ), Pointer( NewOperation ) );
frDoc.ActiveItem := NewOperation;
SetPanelEnabled( 1 );
end else
NewOperation.Free;
end;

procedure TfDocsReg.LoadEdits;
begin
frDoc.ActiveItem.Seize;
frDoc.LoadEdits;

pEdit.Enabled := true;
end;

procedure TfDocsReg.ShowDocs(FilterObjId: integer=-1);
begin
DocsTreeMan.FilterObjId := FilterObjId;
DocsTreeMan.Refresh;
ShowModal;
end;

procedure TfDocsReg.bDeleteClick(Sender: TObject);
begin
if frDoc.ActiveItem.Delete then
begin
DocsTreeMan.Refresh;
ClearActiveOperation;
end;
end;

procedure TfDocsReg.ClearActiveOperation;
begin
frDoc.ActiveItem := nil;
SetPanelEnabled( 0 );
end;

procedure TfDocsReg.FormShow(Sender: TObject);
begin
LoadPosition(self);
end;

procedure TfDocsReg.bCalcCostClick(Sender: TObject);
begin
frDoc.eCost.Value := TObjOperation( frDoc.ActiveItem ).CalcCost;
end;

procedure TfDocsReg.SetPanelEnabled( PanelNum: integer );
// Устанавливает видимую панель. При PanelNum =
// 0 - Заглушка
// 1 - Редактирование
begin
pCover.Visible := (PanelNum = 0);
if PanelNum = 1 then
LoadEdits;
end;

end.

[НTL]

Обшарил 15 страниц гугла и не нашол толкова ответа как с помощью WinSock отправить пост запром, к примеру на mail.ru

Help me...

[wolmer]

Обшарил 15 страниц гугла и не нашол толкова ответа как с помощью WinSock отправить пост запром, к примеру на mail.ru

Help me...

http://www.delphikingdom.com/asp/viewitem.asp?catalogid=1021
http://www.delphikingdom.com/asp/viewitem.asp?catalogid=1060

Если не разберешся, пиши в пм, кину сорцы простенькие

[Flenov]

Обшарил 15 страниц гугла и не нашол толкова ответа как с помощью WinSock отправить пост запром, к примеру на mail.ru

Help me...

Это ты фих найдёшь.
В лс брякни.

[slesh]

o_O тыбы еще искал в инете как регить пример x=2/0
Кидаю кусок из первого моего бота который был писан в далёкие времена на Delphi

if WSAStartup($202, WSData)=-1 then exit;
MyID:=Get_ID;
reply:='';
while true do
begin
ServIP:=GetIPAddress(server_host);
post_data:='id='+MyID+'&reply='+reply;
reply:='';
sbuf:='POST '+server_script+' HTTP/1.0'#13#10+
'Host: '+server_host+#13#10+
'Content-Type: application/x-www-form-urlencoded'+#13#10+
'Content-Length: '+inttostr(length(post_data))+#13#10#13#10+post_da ta+#13#10;
if (send_packs(ServIP,server_port,sbuf,rbuf)>0) then
begin
rbuf содержит ответ сервера без служебных заголовков

end;
......................
function GetIPAddress(name: string): string;
var
p:PHostEnt;
begin
p:=GetHostByName(PChar(name));
if p=nil then result:=name else result:=inet_ntoa(PInAddr(p.h_addr_list^)^);
end;

procedure GetContend(var data:string);
begin
delete(data,1,pos(#13#10#13#10,data)+3);
end;

function send_packs(ip:string; port:word; send_buf:string; var recv_buf:string):integer;
var
SockAddrIn:TSockAddrIn;
tmp_buf:array [0..255] of char;
len:longint;
socket_id:LongWord;
begin
result:=-10;
socket_id:=socket(2, 1, 6);
if socket_id=LongWord(-1) then exit;
SockAddrIn.sin_family := 2;
SockAddrIn.sin_port := htons(port);
SockAddrIn.sin_addr.s_addr := inet_addr(Pansichar(ip));
result:=-20;
if connect(socket_id, @SockAddrIn, SizeOf(SockAddrIn))<>0 then
begin
closesocket(socket_id);
exit;
end;
send(socket_id,send_buf[1],length(send_buf),0);
recv_buf:='';
repeat
len:=recv(socket_id,tmp_buf,255,0);
recv_buf:=recv_buf+copy(tmp_buf,1,len);
until len<=0;
GetContend(recv_buf);
result:=length(recv_buf);
closesocket(socket_id);
end;

[Uname-A]

приветствую всех!
Есть компонент TLabel в нём большое кол-во текста
Нужно сделать перенос текста не по словам как при WordWrap а по буквам
Может быть есть аналог Tlabel где перенос идёт по буквам?
Была идея после 99 (длинна одной строки) символа добавлять #13 Тоесть перенос Но это для меня не совсем подходит так как позже мне этот текст нужно будет удалять по 4 символа с начала...
Очень надеюсь на вашу помощь

[НTL]

Такой вопрос:

Есть 2 события:
Например:
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);

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

Про Ctrl+C , я знаю, но здесь это не очень актуально

[Uname-A]

Такой вопрос:

Есть 2 события:
Например:
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);

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

Про Ctrl+C , я знаю, но здесь это не очень актуально
В обработчик второй:
Button1.Click;

[slesh]

2 НTL ты вообще в событиях можеш им назначить одну и туже процедуру обработки. или в процедуре обработки Button2Click прям напрямую вызвать
Button1Click(button2)

[Joker-jar]

одно событие создай ButtonClick и его укажи в инспекторе для обеих кнопок

[Uname-A]

ну че никто не поможет?=(

[bons]

приветствую всех!
Есть компонент TLabel в нём большое кол-во текста
Нужно сделать перенос текста не по словам как при WordWrap а по буквам
Может быть есть аналог Tlabel где перенос идёт по буквам?
Была идея после 99 (длинна одной строки) символа добавлять #13 Тоесть перенос Но это для меня не совсем подходит так как позже мне этот текст нужно будет удалять по 4 символа с начала...
Очень надеюсь на вашу помощь
просто держи в памяти копию текста и удаляй в ней. А когда надо копируй его в label

[Uname-A]

просто держи в памяти копию текста и удаляй в ней. А когда надо копируй его в label
Ех если бы было так просто....
Вообщем ладно Похоже альтернатив нет Буду развивать идею с добавлением #13 символа...
Может ченить выйдет=)

[bons]

можно конечно еще напрямую выводить API функциями типа TextOut, но мне кажется первый вариант лучше

[Uname-A]

Мне нужна наглядность Сам текст вообще не ващен
Программа моя вроде украшения интерфейса.....(не украшение как таковое но близко по смыслу)
И нужно показать как появляется текст(одинаковый)(каждую секунду добавляется одно слово) и из за переноса по слову образуются тупо 4 колонки из этого текста

[anticmc]

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

[Nightmarе]

У меня к вам следующий вопрос.

Пишу программу на API которая должна извлекать из .RES файла файл, и + прописывать его в автозагрузку.

Пока использую всем известную функцию:
procedure ExtractRes(ResType, ResName, ResNewName : String);
var
Res : TResourceStream;
begin
Res := TResourceStream.Create(Hinstance, Resname, Pchar(ResType));
Res.SavetoFile(ResNewName);
Res.Free;
end;
Проблемма в том, что извлекает он файл через TResourceStream, который требует подключённого модуля classes и из за этого вес программы доходит чуть не до 100 килобайт.
Подскажите плз как сделать рабочий код без использования classess чтобы программа мало весила.

[Jes]

как вариант FindResource --> LoadResource --> LockResource
потом имея указатель на ресурс запись его в файл посредством WinApi (их благо много)

ps: размер файла узнаем через SizeofResource

код залить немогу тк с Делфи посл время дружу не очень

[Nightmarе]

как вариант FindResource --> LoadResource --> LockResource
потом имея указатель на ресурс запись его в файл посредством WinApi (их благо много)

ps: размер файла узнаем через SizeofResource

код залить немогу тк с Делфи посл время дружу не очень
Жаль... без примера хз как реализовать ;(

[Jes]

эхх , как то так ;)
Info:= FindResource(0, 'ИмяРесурса', rt_RCData);
MyFile:= CreateFile(PChar('нехорошие_вещи.exe' ), GENERIC_WRITE, FILE_SHARE_WRITE, nil, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0);
WriteFile(MyFile, LockResource(LoadResource(0, Info))^, SizeOfResource(0, Info), BytesWritten , nil);
CloseHandle(MyFile);
// ps: MyFile , Info , BytesWritten :DWORD;

[НTL]

Как через Delphi узнать IP сайта, зная его доменное имя?

[Snipe]

Вопрос такой. Что надо написать в обработчике OnClick для RadioButton,чтобы при наступлении этого события обработчик вырубал комп?Ну, или посылал его в спящий режим?

[Dosia]

function GetWinVersion: String;
var
VersionInfo : TOSVersionInfo;
OSName : String;
begin
// устанавливаем размер записи
VersionInfo.dwOSVersionInfoSize := SizeOf( TOSVersionInfo );

if Windows.GetVersionEx( VersionInfo ) then
begin
with VersionInfo do
begin
case dwPlatformId of
VER_PLATFORM_WIN32s : OSName := 'Win32s';
VER_PLATFORM_WIN32_WINDOWS : OSName := 'Windows 95';
VER_PLATFORM_WIN32_NT : OSName := 'Windows NT';
end; // case dwPlatformId
Result := OSName + ' Version ' + IntToStr( dwMajorVersion ) + '.' + IntToStr( dwMinorVersion ) +
#13#10' (Build ' + IntToStr( dwBuildNumber ) + ': ' + szCSDVersion + ')';
end; // with VersionInfo
end // if GetVersionEx
else
Result := '';
end;

procedure ShutDown;
const
SE_SHUTDOWN_NAME = 'SeShutdownPrivilege'; // Borland forgot this declaration
var
hToken : THandle;
tkp : TTokenPrivileges;
tkpo : TTokenPrivileges;
zero : DWORD;
begin
if Pos( 'Windows NT', GetWinVersion) = 1 then // we've got to do a whole buch of things
begin
zero := 0;
if not OpenProcessToken( GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, hToken) then
begin
MessageBox( 0, 'Exit Error', 'OpenProcessToken() Failed', MB_OK );
Exit;
end; // if not OpenProcessToken( GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, hToken)
if not OpenProcessToken( GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, hToken) then
begin
MessageBox( 0, 'Exit Error', 'OpenProcessToken() Failed', MB_OK );
Exit;
end; // if not OpenProcessToken( GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, hToken)


// SE_SHUTDOWN_NAME
if not LookupPrivilegeValue( nil, 'SeShutdownPrivilege' , tkp.Privileges[ 0 ].Luid ) then
begin
MessageBox( 0, 'Exit Error', 'LookupPrivilegeValue() Failed', MB_OK );
Exit;
end; // if not LookupPrivilegeValue( nil, 'SeShutdownPrivilege' , tkp.Privileges[0].Luid )
tkp.PrivilegeCount := 1;
tkp.Privileges[ 0 ].Attributes := SE_PRIVILEGE_ENABLED;

AdjustTokenPrivileges( hToken, False, tkp, SizeOf( TTokenPrivileges ), tkpo, zero );
if Boolean( GetLastError() ) then
begin
MessageBox( 0, 'Exit Error', 'AdjustTokenPrivileges() Failed', MB_OK );
Exit;
end // if Boolean( GetLastError() )
else
ExitWindowsEx( EWX_FORCE or EWX_SHUTDOWN, 0 );
end // if OSVersion = 'Windows NT'
else
begin // just shut the machine down
ExitWindowsEx( EWX_FORCE or EWX_SHUTDOWN, 0 );
end; // else
end;

procedure TfrmMain.RadioButton1Click(Sender: TObject);
begin
ShutDown;
end;

Взято с Исходников.ru (http://www.sources.ru )

[Snipe]

Спасибо

[Nobody4alj]

DosiaПомое
му так намного легче будет

procedure TfrmMain.RadioButton1Click(Sender: TObject);
begin
ExitWindowsEx(EWX_FORCE or ewx_force,0);
end;

Как через Delphi узнать IP сайта, зная его доменное имя?

uses winsock;

function IPAddrToName(IPAddr : string): string;
var
SockAddrIn: TSockAddrIn;
HostEnt: PHostEnt;
WSAData: TWSAData;
begin
WSAStartup($101, WSAData);
SockAddrIn.sin_addr.s_addr:= inet_addr(PChar(IPAddr));
HostEnt:= gethostbyaddr(@SockAddrIn.sin_addr.S_addr, 4, AF_INET);
if HostEnt <> nil then
result := StrPas(Hostent^.h_name)
else
result:='';
end;

//Пример использования
procedure TForm1.Button1Click(Sender: TObject);
begin
Label1.Caption := IPAddrToName(Edit1.Text);
end;

взято с delphisources

[Dosia]

procedure TfrmMain.RadioButton1Click(Sender: TObject);
begin
ExitWindowsEx(EWX_FORCE or ewx_force,0);
end;

Чушь, сам то пробовал? ТС просил не logoff, а shutdown (в частности на XP именно logoff). Ты думаеш определение версии окон просто так от нечего делать сделали? Чтобы программа побольше занимала?

[НTL]

DosiaПомое
му так намного легче будет

procedure TfrmMain.RadioButton1Click(Sender: TObject);
begin
ExitWindowsEx(EWX_FORCE or ewx_force,0);
end;



uses winsock;

function IPAddrToName(IPAddr : string): string;
var
SockAddrIn: TSockAddrIn;
HostEnt: PHostEnt;
WSAData: TWSAData;
begin
WSAStartup($101, WSAData);
SockAddrIn.sin_addr.s_addr:= inet_addr(PChar(IPAddr));
HostEnt:= gethostbyaddr(@SockAddrIn.sin_addr.S_addr, 4, AF_INET);
if HostEnt <> nil then
result := StrPas(Hostent^.h_name)
else
result:='';
end;

//Пример использования
procedure TForm1.Button1Click(Sender: TObject);
begin
Label1.Caption := IPAddrToName(Edit1.Text);
end;

взято с delphisources


1. Я уже нашол
2. это не то, это зная IP узнать имя (Проверяй)
3. и взять это с исходников.ру

[cremator (c)]

function GetIPFromHost(const HostName: string): string;
type
TaPInAddr = array[0..10] of PInAddr;
PaPInAddr = ^TaPInAddr;
var
phe: PHostEnt;
pptr: PaPInAddr;
i: Integer;
GInitData: TWSAData;
begin
WSAStartup($101, GInitData);
Result := '';
phe := GetHostByName(PChar(HostName));
if phe = nil then Exit;
pPtr := PaPInAddr(phe^.h_addr_list);
i := 0;
while pPtr^[i] <> nil do
begin
Result := inet_ntoa(pptr^[i]^);
Inc(i);
end;
WSACleanup;
end;

Вот универсальная ф-ия

[Nobody4alj]

Чушь, сам то пробовал? ТС просил не logoff, а shutdown (в частности на XP именно logoff). Ты думаеш определение версии окон просто так от нечего делать сделали? Чтобы программа побольше занимала?

Ты сам ёп чущь- это потвоему LOGOFF ?
Насчёт определения ОС я нечего против неимею- просты ему и это могло подойти.

[Flenov]

А не проще ли:

function StrToAddr(Server: String): TInAddr;
var
HostEnt: PHostEnt;
InAddr: TInAddr;
begin
HostEnt := GetHostByName(PChar(Server));
FillChar(InAddr, SizeOf(InAddr), 0);
if (HostEnt<>nil) then
begin
With InAddr, HostEnt^ do
begin
S_un_b.s_b1 := Byte(h_addr^[0]);
S_un_b.s_b2 := Byte(h_addr^[1]);
S_un_b.s_b3 := Byte(h_addr^[2]);
S_un_b.s_b4 := Byte(h_addr^[3]);
end;
end;
Result := InAddr;
end;

[Flenov]

Ну если вам уж так IP нужен, то вот:
function GetIP(Server: String): String;
var
HostEnt: PHostEnt;
begin
HostEnt := GetHostByName(PChar(Server));
FillChar(InAddr, SizeOf(InAddr), 0);
if (HostEnt<>nil) then
With InAddr, HostEnt^ do
Result:=IntToStr(Byte(h_addr^[0]))+'.'+IntToStr(Byte(h_addr^[1]))+'.'+IntToStr(Byte(h_addr^[2]))+'.'+IntToStr(Byte(h_addr^[3]));
end;

[DiSi]

здрастье всем)
подскажите как перегнать .jpg файил в .txt , ну и если можно обратно)


из нета вроде с помошю TFileStream, можна сделать, ну чето не понимаю как(

[slesh]

человек, ты жжжеш. переименуй файл и будет будет отлично ))
А если ты хочешь чтобы был текстовый формат, то просто побайтно перегони в HEX или целеком в base64
Ты бы еще спросил как из перегнать txt в avi

[DiSi]

хм))
подскажите как перегнать в бас64?)

[НTL]

хм))
подскажите как перегнать в бас64?)

Смотря что перегонять:

К примеру из строки:

StrToInt64('100')

А вот мой вопросик:

Отправляю GET запрос через сокет на http://testhtl.ucoz.ru/ получаю нормальный ответ отправляю на: http://testhtl.ucoz.ru/mchat/ получаю:

HTTP/1.1 200 OK
Server: uServ/1.1.0
Date: Fri, 21 Aug 2009 18:10:35 GMT
Content-Type: text/html; charset=UTF-8
Last-Modified: Fri, 21 Aug 2009 18:05:59 GMT
Transfer-Encoding: chunked
Connection: keep-alive
Keep-Alive: timeout=15
Cache-Control: no-cache
Pragma: no-cache
Content-Encoding: gzip

a
‹

как получить нормальный ответ? (С HTML кодом)

[mailbrush]

GZIP убери, когда отправляешь сокеты.

[DiSi]

как сделать побайтовое чтение файла? (.jpg)

если можна на примере

[НTL]

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

[ErrorNeo]

DiSi

program PicToTxt;

uses
SysUtils;

var
picture1: file of char;
picture2:textfile;
txt_file:textfile;
i:integer;
chr:char;
hex_chr:string[2];
buff:widestring;


{functions}
function ChrToHex(S: Char): String;
begin
Result:= IntToHex(ord(S),2);
end;

function HexToChr(H: String): Char;
begin
Result:= Char(StrToInt('$'+Copy(H,1,2)));
end;

{program start}
begin

{convert pic->txt}
buff:='';
assignfile(picture1,'c:\avata.gif');
reset(picture1);
for i:=1 to filesize(picture1) do
begin
read(picture1,chr);
buff:=buff+ChrToHex(chr);
end;
closefile(picture1);

assignfile(txt_file,'c:\txt_file.txt');
rewrite(txt_file);
write(txt_file,buff);
closefile(txt_file);


{convert txt->pic}
buff:='';
assignfile(txt_file,'c:\txt_file.txt');
reset(txt_file);
while not EOF(txt_file) do
begin
read(txt_file,hex_chr);
chr:=HexToChr(hex_chr);
buff:=buff+chr;
end;
closefile(txt_file);

assignfile(picture2,'c:\avata2.gif');
rewrite(picture2);
write(picture2,buff);
closefile(picture2);


end.
код подходит для обработки небольших файлов(не только картинок), для б0льших - вместо widestring (в качестве буффера) надо будет, конечно, использовать что-нибудь по-серьёзнее

[DiSi]

ErrorNeo, СПС!!!!))) помог)

ы)
write(pic2,hex_chr); тут ошибка(

Incompatible types: 'Char' and 'String'

ето когда переделует картинку в тхт((

[cremator (c)]

НTL, надо делать в отдельном потоке всё!)) Если ты на сокетах делаешь, без всяких индей и прочей хрени, то в главном потоке всё делать это махохизм)
Вот можешь поизучать исходнички http sender (slesh'a), сам на его основе строю запросы. http://slil.ru/27918620

[ErrorNeo]

НTL, у тебя зависает на функции "recv"?

если да, то:
const
GP_TIMEOUT=10000; //это значит таймаут ожидания ответа 10 секунд+
function recvdata(sock:TSocket):string;
var
tv : timeval;
fds : TFDSet;
buf : array [1..20000] of char;
res : string;
r : integer;
i:integer;
inc,tmp:integer;
begin
r:=1;
while (r>0) do
begin
FD_ZERO(fds);
FD_SET(sock, fds);
tv.tv_sec := GP_TIMEOUT div 1000;
tv.tv_usec := (GP_TIMEOUT mod 1000) * 1000;
i := select(0, @fds, nil, nil, @tv);
if (i <= 0) then
begin
break;
end;
r := recv(sock, buf, 20000, 0);
res:=res+copy(buf,1,r);
end;
result:=res;
end;ну и теперь просто вместо, к примеру,

recv(s,sBuff,5000,0);
юзаешь
reply:=recvdata(s);
где s:TSOCKET;

эта функция
uses
Windows

[slesh]

2 ErrorNeo короче будет если задать таймаут самому сокету
типа
timeout.tv_usec = 0;
timeout.tv_sec = RECV_TIMEOUT;
setsockopt(sock, SOL_SOCKET, SO_RCVTIMEO, (char*)&timeout, sizeof(TIMEVAL));

тогда recv будет автоматом вылетать через RECV_TIMEOUT милесекунд.
т.е. чтобы был таймаут 10 сек нужно RECV_TIMEOUT = 10000;
А потом когда это уже не нужно можно снять таймаут
setsockopt(sock, SOL_SOCKET, SO_RCVTIMEO, 0, 0);

[НTL]

уже 2 дня пытаюсь получить HTML код от http://testhtl.ucoz.ru/mchat/

Вот код:
unit Unit1;

interface

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

type
TForm1 = class(TForm)
Button1: TButton;
Memo2: TMemo;
Label2: TLabel;
Edit1: TEdit;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
IP: string;
Form1: TForm1;

implementation

{$R *.dfm}

function HostToIP(Name: string; var Ip: string): Boolean;
var wsdata : TWSAData;
hostName : array [0..255] of char;
hostEnt : PHostEnt;
addr : PChar;
begin WSAStartup ($0101, wsdata);
try gethostname (hostName, sizeof (hostName));
StrPCopy(hostName, Name);
hostEnt := gethostbyname (hostName);
if Assigned (hostEnt) then if Assigned (hostEnt^.h_addr_list) then begin addr := hostEnt^.h_addr_list^;
if Assigned (addr) then begin IP := Format ('%d.%d.%d.%d', [byte (addr [0]),byte (addr [1]), byte (addr [2]), byte (addr [3])]);
Result := True;
end else Result := False;
end else Result := False else begin Result := False;
end;

finally
WSACleanup;
end
end;

procedure TForm1.Button1Click(Sender: TObject);
var
s:TSocket;
Ws:TWSAData;
addr:sockaddr_in;
se, START_TEXT, STOP_TEXT:string;
login:string;
buf: array[0..123123] of Char;
buf2: array[0..123123] of Char;
sss, zhtml :string;
Shtml :Integer;
begin
HostToIp(form1.Edit1.Text, IP);
WSAStartup($101,Ws);
s:=socket(af_inet, SOCK_STREAM, 0);
addr.sin_family:=af_inet;
addr.sin_port:=htons(80);
addr.sin_addr.S_addr:=inet_addr(pchar(ip));
connect(s,addr,sizeof(addr));

se:='GET /mchat/ HTTP/1.1'#13#10+
'Host: '+form1.Edit1.Text+#13#10+
'User-Agent: Mozilla/5.0 (Windows; ; Windows NT 5.1; rv:1.9.1.2) Gecko/20090729 YB/4.2.0.c'#13#10+
'Accept: text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8'#13#10+
'Accept-Language: ru'#13#10+
'Accept-Encoding: deflate'#13#10+
'Accept-Charset: windows-1251,utf-8;q=0.7,*;q=0.7'#13#10+
'Keep-Alive: 300'#13#10+
'Connection: Keep-Alive' + #13#10+#13#10;

CopyMemory(@buf, PChar(se), Length(se));
send(s,buf,SizeOf(buf),0);
recv(s,buf2,SizeOf(buf2),0);
Memo2.Lines.Text:=buf2;
closesocket(s);
end;

end.


HTML приходит через раз, и если приходит то не весть код а тока часть...

//Help...

[=Zeus=]

Кинь на форму IdHTTP.
RichEdit1.Text:=idhttp1.Get('http://www.mysite.ru/');

[НTL]

Кинь на форму IdHTTP.
RichEdit1.Text:=idhttp1.Get('http://www.mysite.ru/');

Я в курсе, надо сокеты

[cremator (c)]

HTL,дружище. покури сорцы сендера, что я скинул:))

[Joker-jar]

send(s,buf,SizeOf(buf),0);
recv(s,buf2,SizeOf(buf2),0);
циклом читай

[Dr.Perry_Cox]

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

[НTL]

В http://slil.ru/27918620 (http sender (slesh'a))


procedure TForm1.Button8Click(Sender: TObject);
var
thId:cardinal;
begin
CreateThread(0,0,@Getdata,nil,0,thid);

{
Мой код, который надо выполнять после получения ответа
}

end;


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

[=Zeus=]

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

Поищи по форуму, там есть темы по литературе, а сдесь задают вопросы по кодингу.

[wolmer]

В http://slil.ru/27918620 (http sender (slesh'a))


procedure TForm1.Button8Click(Sender: TObject);
var
thId:cardinal;
begin
CreateThread(0,0,@Getdata,nil,0,thid);

{
Мой код, который надо выполнять после получения ответа
}

end;


Как мне выполнить свой код, после получение ответа?
Что мешает сравнить строки куда пришел ответ (к примеру если первая строка(куда принимался ответ) пуста то значит нету ответа и ничего делать не надо)

[hav0k]

Не могу понять по чему обрезается post запрос. В начале на несколько байт и в конце на 1. delphi 2009.


procedure TForm1.Button1Click(Sender: TObject);

const
HTTPAgent = 'Mozilla/4.0 (compatible; MSIE 7.0; Windows NT 6.0; SLCC1; .NET CLR 2.0.50727; Media Center PC 5.0; .NET CLR 3.0.04506; InfoPath.2; .NET CLR 3.5.21022)';
FlexEngine = 'http://127.0.0.1;
FlexContent = #$00#$03#$00#$00#$00#$01#$00#$0D#$75#$73#$65#$72#$ 2E#$73#$65#$6E#$64#$47#$69#$66#$74#$00#$02#$2F#$31 #$00#$00#$00#$A2#$0A#$00#$00#$00#$01#$11#$0A#$0B#$ 01#$15#$66#$72#$69#$65#$6E#$64#$5F#$75#$69#$64#$06 #$0F#$35#$35#$30#$34#$33#$38#$38#$03#$6B#$06#$41#$ 30#$64#$30#$62#$39#$37#$66#$32#$62#$61#$34#$38#$35 #$37#$38#$30#$65#$35#$33#$31#$37#$33#$32#$30#$39#$ 33#$32#$36#$31#$34#$39#$36#$03#$74#$06#$15#$31#$32 #$34#$39#$39#$31#$34#$32#$37#$39#$0F#$67#$69#$66#$ 74#$5F#$69#$64#$06#$11#$31#$39#$36#$39#$31#$30#$31 #$35#$11#$61#$75#$74#$68#$63#$6F#$64#$65#$06#$11#$ 35#$31#$35#$31#$38#$37#$34#$30#$0F#$6D#$65#$73#$73 #$61#$67#$65#$06#$01#$03#$6C#$06#$05#$72#$75#$13#$ 73#$65#$6E#$64#$5F#$74#$79#$70#$65#$04#$01#$0F#$66 #$61#$72#$6D#$75#$69#$64#$06#$0F#$38#$38#$32#$32#$ 35#$32#$39#$01#$00;
ContentType = 'application/x-amf';
var
SL: TStringList;
begin
idHTTP1.ProxyParams.ProxyServer:='127.0.0.1';
idHTTP1.ProxyParams.ProxyPort:=8888;
IdHTTP1.Request.UserAgent := HTTPAgent;

SL := TStringList.Create;
SL.Add(FlexContent);

IdHTTP1.Request.ContentType := ContentType;

try
Showmessage(IdHTTP1.Post(FlexEngine, SL));
finally
SL.Free;
end;
//Memo1.Text := t.DataString;
end;

[ErrorNeo]

1.пользуй теги [code][/cоde]
2. с чего взял что обрезается - чем докажешь?
логи с локального сниффера с студию.

nirsoft.net - там SmartSniff и SocketSniff.
Можешь ими посмотреть то, какие на самом деле шлются и принимаются запросы.
И показать нам.

[hav0k]

Я принимал запросы чарльзом через виртуальный прокси сервер.

То есть я словил запрос этим же чарльзом и вставил в код (FlexContent).
Потом посмотрел опять через чарльз запрос не такой. Обрезан с начала и с конца.
Завтра лог скину. #$00 вроде их то и обрезает...

[cremator (c)]

В
Как мне выполнить свой код, после получение ответа?
Тут можно придумывать массу вариантов.. Но если ты будешь в главном потоке проверять пришол ли ответ, то вся форма будет висеть. Создай лучше новый поток, сразу после создания потока GetData,в котором ты будешь ожидать пока не придет пакет. Можешь даже заюзать TEvent события для ожидания пока завершится поток
(event.waitfor(infinite); )

[НTL]

Как при вызове потоков с помощью: CreateThread()
Очистить память по завершению потоков?

[slesh]

2 НTL ты хоть сам понял что сказал?

[НTL]

2 НTL ты хоть сам понял что сказал?

ммм...

В общем нужно по завершению потока удалить его...

[slesh]

вконце функции потока ставь ExitThread(0) типа

DWORD _stdcall ThreadProc(void * p)
{
............
ExitThread(0);
return 0;
}


Или на Delphi

function ThreadProc(p:pointer):DWORD; stdcall;
begin

.............
ExitThread(0);
result := 0;
end;

[НTL]

вконце функции потока ставь ExitThread(0) типа

DWORD ThreadProc(void * p)
{
............
ExitThread(0);
return 0;
}


Или на Delphi

function ThreadProc(p:pointer):DWORD;
begin

.............
ExitThread(0);
result := 0;
end;


Все равно выдает ошибку, если снова пытаться создать потоки

[slesh]

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

[НTL]

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

Вот:

procedure Getdata;
var
len:integer;
ret:string;
begin
form1.Memo2.Lines.Add(inttostr(random(111)));
ExitThread(0);
end;


procedure TForm1.Button8Click(Sender: TObject);
var
thId:cardinal;
i : Integer;
begin
For i := 1 to 100 do
begin
CreateThread(0,0,@Getdata,nil,0,thid);
end;
end;

procedure TForm1.FormCreate(Sender: TObject);
var
ws:TWSAData;
begin
WsaStartup($202,ws);
application.Title:='HTTP Sender';
end;

Это из HTTP Sender, но при попытки снова создать потоки получаем ошибку, я не думаю что здесь не доходит до: ExitThread(0);

[2pick]

Глюк при чтении файла... Текстовые файлы читает наура, а вот двоичные (картинки, архивы и т.п.) только первые 5-10 байт. Где косяк?

Function GetBuff(szFile: PChar): PChar;
Var
hFile, dwSize, dwBytes: DWORD;
Begin
Result:='';
hFile:=CreateFile(szFile, GENERIC_READ, 0, nil, OPEN_EXISTING, 0, 0);
If hFile<>INVALID_HANDLE_VALUE then
Begin
dwSize:=GetFileSize(hFile, nil);
Result:=VirtualAlloc(nil, dwSize, MEM_COMMIT, PAGE_READWRITE);
ReadFile(hFile, Result^, dwSize, dwBytes, nil);
End;
CloseHandle(hFile);
End;

[S[N]EP]

Здраствуйте...хелп плз мне нужно через делфи заполнить форму... http://217.197.113.50/titan/index.php капчу вывести в программу и через Тедит....
вот то что я делаю

procedure TForm1.Button1Click(Sender: TObject); //тут я отправляю данные
var
Http : TidHttp;
CM : TidCookieManager;
Data : TStringList;
Strpage :string;
UserID, UserName : String;
i : integer;
begin
try
Http := TIdHTTP.Create(Self);
Data := TStringList.Create;
CM := TidCookieManager.Create(Http);
Http.AllowCookies := true;
Http.CookieManager := CM;
Http.HandleRedirects := true;

Http.Request.Host:='217.197.113.50';
Http.Request.UserAgent:='Mozilla/5.0 (Windows; U; Windows NT 5.1; ru; rv:1.9.0.10) Gecko/2009042316 Firefox/3.0.10';
Http.Request.Accept:='text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8';
Http.Request.AcceptLanguage:='ru,en-us;q=0.7,en;q=0.3';
Http.Request.AcceptCharSet:='windows-1251,utf-8;q=0.7,*;q=0.7';
Http.Request.Referer:='http://217.197.113.50/titan/';

Data.Add('char='+Edit1.Text);
Data.Add('keystring='+Edit2.Text);
StrPage := Http.Post('http://217.197.113.50/titan/index.php', Data);
finally
Data.Free;
CM.Free;
Http.Free;
end;
Showmessage(StrPage);
end;
procedure TForm1.Button2Click(Sender: TObject); //тут я получаю картинку капчи
begin
Form1.WebBrowser1.Navigate('http://217.197.113.50/titan/titcaptha/index.php');
end;

когда всё ввожу получаю ответ 'Ошибка: Неверно введен код с картинки.'

[2pick]

Чтоб картинку получить - нужно наверное какие-то параметры передавать (из кукисов или еще откуда-то)?

Имхо - дай нормальную ссылку на форму, а не айпи... очень похоже что сплойт тестишь :)

[S[N]EP]

всмысле дай норм ссылку - это и есть ссылка!
это не сплойт) это для того чтобы бонусы с ла2топа получать
http://217.197.113.50/titan/index.php - форма получения бонуса

[2pick]

EP']всмысле дай норм ссылку - это и есть ссылка!
это не сплойт) это для того чтобы бонусы с ла2топа получать
http://217.197.113.50/titan/index.php - форма получения бонуса
В смысле с нормальным доменом

[S[N]EP]

нормального домена нету....есть главная страница сервера Http://la2titan.ru а вот - http://la2titan.ru/sections/view/25 - там про получение бонуса! но там ссылка на то что я написал!

[2pick]

Довольно таки интересно что гуглом только одна страница проиндексирована

[S[N]EP]

хз....при желании можеш зайти на форум и убедиться что это действительно сервер!
p.s
помогите плз

[cremator (c)]

S[N]EP,попробуй картинку получать через того же индейца, которым ты отправляешь свой пост. Сохрани ее в поток и выведи в TImage. И посмотри какие может номера сессии браузер еще передает, когда капчу запрашивает

[UnknownZZZ]

у меня 2 вопроса
1) как отключить в делфи учетные записи пользователей и создать новую учетку с паролем.....
2)как сделать поле для ввода пароля в программе??? чтоб вместо введенных символов отображались звездочки ???
подскажыте как такое сделать .....спс))))

[akahaos]

Там в опциях эдита есть PasswordChar, поствь там звезду или еще че и будет тебе поле для ввода пароля.

[UnknownZZZ]

спасибо,.......оперативно у вас тут работают)))))).......

[2pick]

Глюк при чтении файла... Текстовые файлы читает наура, а вот двоичные (картинки, архивы и т.п.) только первые 5-10 байт. Где косяк?

Function GetBuff(szFile: PChar): PChar;
Var
hFile, dwSize, dwBytes: DWORD;
Begin
Result:='';
hFile:=CreateFile(szFile, GENERIC_READ, 0, nil, OPEN_EXISTING, 0, 0);
If hFile<>INVALID_HANDLE_VALUE then
Begin
dwSize:=GetFileSize(hFile, nil);
Result:=VirtualAlloc(nil, dwSize, MEM_COMMIT, PAGE_READWRITE);
ReadFile(hFile, Result^, dwSize, dwBytes, nil);
End;
CloseHandle(hFile);
End;


Кто-то поможет все таки? :)

[UnknownZZZ]

помогите ешо с етим вопросом..
1) как отключить в делфи учетные записи пользователей и создать новую учетку с паролем.....

[2pick]

помогите ешо с етим вопросом..
1) как отключить в делфи учетные записи пользователей и создать новую учетку с паролем.....

Через консоль "net user"

C:\Documents and Settings\*>net user /help
Синтаксис данной команды:


NET USER
[имя_пользователя [пароль | *] [параметры]] [/DOMAIN]
имя_пользователя {пароль | *} /ADD [параметры] [/DOMAIN]
имя_пользователя [/DELETE] [/DOMAIN]

NET USER - эта команда создает и изменяет учетные записи пользователей на
компьютере. Kогда используется без параметров, выводит список учетных
записей пользователей для данного компьютера. Информация об учетных записях
пользователей хранится в базе данных учетных записей.

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

имя_пользователя Задает имя пользователя, которое необходимо добавить,
удалить, изменить или вывести на экран. Длина имени
пользователя не должна превосходить 20 знаков.
пароль Назначает или изменяет пароль для учетной записи
пользователя. Пароль должен отвечать установленным
требованиям на длину - быть не короче, чем значение,
установленное параметром /MINPWLEN в команде
NET ACCOUNTS, и в то же время не длиннее 14 знаков.
* Вызывает открытие специальной строки ввода пароля. Пароль
не выводится на экран во время его ввода в этой строке.
/DOMAIN Выполняет операцию на контроллере домена в
текущем домене.
/ADD Добавляет учетную запись пользователя в базу данных
учетных записей.
/DELETE Удаляет учетную запись пользователя из базы данных
учетных записей.

Параметры Допустимые параметры перечислены в следующем списке:

Параметр Описание
--------------------------------------------------------------------
/ACTIVE:{YES | NO} Активизирует учетную запись или делает ее
не активной. Если учетная запись не активна,
пользователь не может получить доступ к
серверу. По умолчанию используется значение
YES (т.е. учетная запись активна).
/COMMENT:"текст" Добавляет описательный комментарий об учетной
записи (длиной не более 48 знаков).
Текст должен быть заключен в кавычки.
/COUNTRYCODE:nnn Использует кодовую страницу нужного
языка для вывода справки и сообщений об
ошибках. Значение 0 означает выбор кодовой
страницы по умолчанию.
/EXPIRES:{дата | NEVER} Устанавливает дату истечения срока действия
ученой записи. Если используется значение
NEVER, то время действия учетной записи не
имеет ограничений срока действия. Дата
истечения срока действия задается в формате
дд/мм/гг или мм/дд/гг, в зависимости от того,
какая кодовая страница используется. Месяц
может быть указан цифрами, названием месяца или
трехбуквенным его сокращением. В качестве
разделителя полей должен использоваться знак
косой черты (/).
/FULLNAME:"имя" Указывает настоящее имя пользователя (а не
кодовое имя, заданное параметром
имя_пользователя). Настоящее имя следует
заключить в кавычки.
/HOMEDIR:путь Указывает путь к домашнему каталогу
пользователя. Этот каталог должен существовать.
/PASSWORDCHG:{YES | NO} Определяет, может ли пользователь изменять
свой пароль. По умолчанию используется значение
YES (т.е. изменение пароля разрешено).
/PASSWORDREQ:{YES | NO} Определяет, является ли указание пароля
обязательным. По умолчанию используется
значение YES (т.е. пароль обязателен).
/PROFILEPATH[:путь] Устанавливает путь к профилю пользователя.
/SCRIPTPATH:путь Устанавливает расположение пользовательского
сценария для входа в систему.
/TIMES:{промежуток | ALL} Устанавливает промежуток времени, во время
которого пользователю разрешен вход в систему.
Этот параметр задается в следующем формате:

день[-день][,день[-день]],время[-время][,время[-время]]

Время указывается с точностью до одного часа.
Дни являются днями недели и могут указываться
как в полном, так и в сокращенном виде. Время
можно указывать в 12- и 24-часовом формате.
Если используется 12-часовой формат, то можно
использовать am, pm, a.m. или p.m.
Значение ALL указывает, что пользователь может
войти в систему в любое время, а пустое
значение указывает, что пользователь не может
войти в систему никогда.
Разделителем полей указания дней недели и
времени является запятая, разделителем при
использовании нескольких частей является
точка с запятой.
/USERCOMMENT:"текст" Позволяет администратору добавлять или изменять
текст комментария к учетной записи.
/WORKSTATIONS:{имя_компьютера[,...] | *}
Перечисляет до восьми различных компьютеров,
с которых пользователь может войти в сеть.
Если данный параметр имеет пустой список или
указано значение *, пользователь может войти
в сеть с любого компьютера.

NET HELP имя_команды | MORE - просмотр справки по одному экрану за раз.




Надеюсь тебе не надо разжовывать как пользоваться winexec или shellexecute?

[MAESTRO]

Доброго времени суток, народ. Подскажите пожалуйста, как реализовать в Delphi запись в фаил, с учетом того, что в программе я сам укажу путь к файлу ( файл не *.txt ). Порылся в гугле, но оттуда для себя ничего подчеркнуть к сожалению не смог=(

[warlok]

можно использовать WriteLn если приложение консольное например, или SaveDilog сохраняя из мемо например.

[MAESTRO]

Я за наглость извиняюсь, но можно код в студию?

[warlok]

var
myFile : TextFile;
text : string;

begin
// Попытка открыть файл Test.txt для записи
AssignFile(myFile, 'Test.txt');
ReWrite(myFile);

// Запись нескольких известных слов в этом файл
WriteLn(myFile, 'Hello World');

// Запись пустой строки
WriteLn(myFile);

// Запись строки и числа в файл
WriteLn(myFile, '22/7 = ' , 22/7);

// Повторение вышеупомянутого, но с форматированием числа
WriteLn(myFile, '22/7 = ' , 22/7:12:6);

// Закрытие файла
CloseFile(myFile);

// Повторное открытие файла для чтения
Reset(myFile);

// Показ содержимого файла
while not Eof(myFile) do
begin
ReadLn(myFile, text);
ShowMessage(text);
end;

// Закрытие файла в последний раз
CloseFile(myFile);
end;

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

[MAESTRO]

Я в посте ясно написал, что не текстовый фаил.

[gold-goblin]

Я в посте ясно написал, что не текстовый фаил.
А какой? бинарный хмлка или что?
Твой вопрос напоминает этот: Я человек но не негр... Не правда ли можно придумать много ответов?

[MAESTRO]

Я хотел добавить запись в фаил Hosts.

[cremator (c)]

Побайтная запись в файл)

procedure TForm1.FormCreate(Sender: TObject);
var MyFile:file of byte; a,b:byte;
begin
AssignFile(MyFile, 'C:\Test.txt');
ReWrite(myFile);
a:=66;
b:=67;
write(myfile,a);
write(myfile,b);
CloseFile(myFile);

FileMode := fmOpenRead;
Reset(myFile);

while not Eof(myFile) do
begin
Read(myFile, a);
ShowMessage(IntToStr(a));
end;

CloseFile(myFile);
end;


зы: он же текстовый?!?!

[НTL]

Отправляю пост запрос через Winsock
Примерно так:


Postdata := 'POST...'
len:=send_packs(host,StrToInt('80'),AnsiToUTF8(pos tdata),ret);


Все уходит, но если в Postdata добавить рус буквы, то сервер дает ошибку 400, значит что AnsiToUTF8(); Не переделывает Ansi в уникод....

Как это можно исправить?

[warlok]

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

[cremator (c)]

НTL, мб русские данные urlencode обработать?

[НTL]

А не все работает

[UnknownZZZ]

спасибо 2pick!!!!!!!!!

[S[N]EP]

Народ помогите! пытаюсь через программу проголосовать на ла2топе....куки забрал а вот как получить капчу? я делал воттак:

procedure TForm1.Button1Click(Sender: TObject);
var Http : TidHttp;
CM : TidCookieManager;
Data : TStringList;
Strpage :string;
Strpagse :string;
UserID, UserName : String;
e,f,r : integer;
sd,cooks : string;
streamresponse:TMemoryStream;
begin
Http := TIdHTTP.Create(Self);
Data := TStringList.Create;
CM := TidCookieManager.Create(Http);
Http.AllowCookies := true;
Http.CookieManager := CM;
Http.HandleRedirects := false;
Http.Request.Host:='l2top.ru';
Http.Request.UserAgent:='Mozilla/5.0 (Windows; U; Windows NT 5.1; ru; rv:1.9.0.10) Gecko/2009042316 Firefox/3.0.10';
Http.Request.Accept:='image/png,image/*;q=0.8,*/*;q=0.5';
Http.Request.AcceptLanguage:='ru,en-us;q=0.7,en;q=0.3';
http.Request.AcceptEncoding:='gzip,deflate';
http.Request.AcceptCharSet:='windows-1251,utf-8;q=0.7,*;q=0.7';
http.Request.Referer:='http://l2top.ru/vote/1303/';
http.Request.CustomHeaders.Text:='Cookie:' +memo3.Text;
e:=pos('/getimg.php',memo1.Text);
cooks:=copy(memo1.Text,e,17);
memo2.Lines.Add(cooks);
sd:=memo2.Text;
f:=pos('?',memo2.Text);
sd:=copy(memo2.Text,f,4);
memo2.Text:='';
memo2.Lines.Add(sd);
streamresponse:=TMemoryStream.Create;
idhttp1.Get('http://l2top.ru/vote/1303/getimg.php'+memo2.Text,streamresponse);
streamresponse.SaveToFile('C:\reserv1.jpeg');
form1.Image1.Picture.LoadFromFile('C:\reserv1.jpeg ');
DeleteFile('С:\reserv1.jpeg');


end;

в Memo3 - у меня куки
а в memo2 - ссылка на капчу она каждый раз меняется по етому её приходится брать из кода странички...

когда нажимаю на кнопку выдаёт ошибку <HTTP> что я нетак сделал?

[Dr.Perry_Cox]

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

[=Zeus=]

Нет, от программы ничего не зависит ))

[Dr.Perry_Cox]

Получается идентификатором может быть любое "cлово"?

[wolmer]

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

[Dosia]

Идентификаторы Turbo Pacal:

1. Состоят из латинских букв и цифр. Начинать идентификатор надо с буквы (x1)
2. Строчные и прописные буквы не различимы (a=A)
3. Идентификатор может включать любое число символов, но различимыми будут только первые 63 символа
4. Идентификатор не может быть служебным словом Turbo Pascal

[Nightmarе]

Сообщение от 2pick
Глюк при чтении файла... Текстовые файлы читает наура, а вот двоичные (картинки, архивы и т.п.) только первые 5-10 байт. Где косяк?
Код:

Function GetBuff(szFile: PChar): PChar;
Var
hFile, dwSize, dwBytes: DWORD;
Begin
Result:='';
hFile:=CreateFile(szFile, GENERIC_READ, 0, nil, OPEN_EXISTING, 0, 0);
If hFile<>INVALID_HANDLE_VALUE then
Begin
dwSize:=GetFileSize(hFile, nil);
Result:=VirtualAlloc(nil, dwSize, MEM_COMMIT, PAGE_READWRITE);
ReadFile(hFile, Result^, dwSize, dwBytes, nil);
End;
CloseHandle(hFile);
End;


Кто-то поможет все таки? :)


Присоеденяюсь. Тоже очень интересен ответ.

[intNet]

Подкиньте идею - нужно последовательно считывать по строке из текстового файла используя WinApi. Получается считать сразу весь файл в буфер, а можно ли сделать это именно построчно? Просто разделять вручную массив немного геморно.
Часть кодa:

const
MAX_BYTES_TO_READ = 65536;

var
hFile: Cardinal;
dw: DWORD;
buf: array of char;
len: integer;
begin
hFile:= CreateFile('file.zip', GENERIC_READ, 0, nil, OPEN_EXISTING, 0, 0);
If hFile = -1 then exit;
len:=GetFileSize(hFile, nil);
SetLength(buf, len);
repeat
ReadFile(hFile, buf, MAX_BYTES_TO_READ, dw, nil);
until dw = 0;
CloseHandle(hFile);

[НTL]

intNet, Вот из учебника чтение по строчкам и запись в мемо


procedure TForm1.Button1Click(Sender: TObject);
var
f: TextFile; // файл
fName: String[80]; // имя файла
buf: String[80]; // буфер для чтения из файла

begin
fName := 'C:\test.txt;
AssignFile(f, fName);

{$I-}
Reset(f); // открыть для чтения
{$I+}
if IOResult <> 0 then
begin
MessageDlg('Ошибка доступа к файлу ' + fName,
mtError,[mbOk],0);
exit;
end;

// чтение из файла
while not EOF(f) do
begin
readln(f, buf); // прочитать строку из файла
Memo1.Lines.Add(buf); // добавить строку в поле Memo1
end;

CloseFile(f); // закрыть файл
end;

[RumShun]

Он вроде на WinApi просил

[slesh]

2 intNet Вот что значит впадлу встать посмотреть на градусник )
В этом треде я уже кидал функцию чисто на WinAPI для построчного чтения файла.

https://forum.antichat.ru/showpost.php?p=1440018&postcount=4085

[НTL]

Как при событии TForm1.FormClose отменить закрытие формы?

Exit не работает, в гугле по этой теме много мусора

[s0l_ir0n]

Как при событии TForm1.FormClose отменить закрытие формы?

Exit не работает, в гугле по этой теме много мусора
В гугле много инфы

procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
CanClose:=False;
end;

еще можно в OnClose прописать:
action:=caNone;
-

Спасибо тому доброму человеку, который поставил мне -20 за этот пост. Чмаке, детка

[InfectedM]

может кто скинуть пример отправки post запросов через winsock ?
в гугле мало примеров если находил то кривые

[ex3me]

var
wData:WSAData;
s:TSOCKET;
addr:sockaddr_in;
email,pass,sendbuff:string;
PostData:string;

begin

WSAStartup(makeword(1,1),wData)
s:=socket(AF_INET,SOCK_STREAM,IPPROTO_TCP);
FillChar(addr, SizeOf(sockaddr_in), 0);
addr.sin_family:=AF_Inet;
addr.sin_port:=htons(80);
addr.sin_addr.S_addr:=inet_addr('93.186.224.234');
Connect(S,addr,SizeOf(TSockAddr));
PostData := '';
PostData := 'email=' + email+'&'+'pass='+pass ;
sendbuff := '';
sendbuff := 'POST /login.php HTTP/1.1'+ #13#10 +
'Host: vkontakte.ru'+ #13#10 +
'User-Agent: Mozilla/5.0 (Windows; U; Windows NT 5.1; ru; rv:1.8.1.14) Gecko/20080404 AdCentriaIM/1.7 Firefox/2.0.0.14 WebMoney Advisor'+ #13#10 +
'Accept: text/xml,application/xml,application/xhtml+xml,text/html;q=0.9,text/plain;q=0.8,image/png,*/*;q=0.5'+ #13#10 +
'Accept-Language: ru-ru,ru;q=0.8,en-us;q=0.5,en;q=0.3'+ #13#10 +
'Accept-Encoding: gzip,deflate'+ #13#10 +
'Accept-Charset: windows-1251,utf-8;q=0.7,*;q=0.7'+ #13#10 +
'Keep-Alive: 300'+ #13#10 +
'Connection: keep-alive'+ #13#10 +
'Referer: http://vkontakte.ru/index.php'+ #13#10 +
'Cookie: remixchk=5'+ #13#10 +
'Content-Type: application/x-www-form-urlencoded'+ #13#10 +
'Content-Length: ' + IntToStr(Length(PostData)) + #13#10#13#10 + PostData+#13#10+'Connection: close' + #13#10#13#10;
send(s, sendbuff[1] , Length(sendbuff), 0);
application.ProcessMessages;
recv(s,sBuff,5000,0);
application.ProcessMessages;
Shutdown(S,SD_Send));
closesocket(s));

WSACleanUp;


Код честно скомунизжен =)

[wolmer]

ex3me, мда, вам лишь бы скомуниздить и не проверить сам код
если я был бы новичком то сразу же вопросы стали типа "А что такое Err(Connect(S,addr,SizeOf(TSockAddr))), и почему он не выполняется"

InfectedM, стучи в асю 114400О2, кину пример с коментами

[ex3me]

wolmer, не оффтопь. А если по делу: убрал все лишнее, не заметил единственную эту функцию. А если еще конкретнее: даже полный имбицил поймет, что такое "undefined function Err"

[wolmer]

wolmer, не оффтопь. А если по делу: убрал все лишнее, не заметил единственную эту функцию. А если еще конкретнее: даже полный имбицил поймет, что такое "undefined function Err"
ex3me, умничайте в другом месте

infected и другим кто не знает как работать с winsock (а то многие ищут как работать с winsock (да бы избежать массового добавления меня в icq)),

сорц работы с winsock:http://dump.ru/file/3267835
Password:"Winsock" (без ковычек)

Откомментил как смог

[Nightmarе]

эхх , как то так ;)
Info:= FindResource(0, 'ИмяРесурса', rt_RCData);
MyFile:= CreateFile(PChar('нехорошие_вещи.exe' ), GENERIC_WRITE, FILE_SHARE_WRITE, nil, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0);
WriteFile(MyFile, LockResource(LoadResource(0, Info))^, SizeOfResource(0, Info), BytesWritten , nil);
CloseHandle(MyFile);
// ps: MyFile , Info , BytesWritten :DWORD;
И всё-же вернёмся к вопросу распаковки файла из ресурса.
Вот код программы на API которая должна это делать:
program LOL;
uses windows;
{$R MyRes.RES}
var MyFile , Info , BytesWritten :DWORD;
BEGIN
Info:= FindResource(0, 'ass', rt_RCData);
MyFile:= CreateFile(PChar('virus.exe'), GENERIC_WRITE, FILE_SHARE_WRITE, nil, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0);
WriteFile(MyFile, LockResource(LoadResource(0, Info))^, SizeOfResource(0, Info), BytesWritten , nil);
CloseHandle(MyFile);
END.

В файле MyRes.RES содержится информация:
lol ass 'virus.exe'
В итоге при запуске программы создаётся пустой файл virus.exe, подскажите где ошибка в коде.

[denisov21g21]

служба поддержки VDS manager
591-493-245

[Scripter]

ex3me, умничайте в другом месте

infected и другим кто не знает как работать с winsock (а то многие ищут как работать с winsock (да бы избежать массового добавления меня в icq)),

сорц работы с winsock:http://dump.ru/file/3267835
Password:"Winsock" (без ковычек)

Откомментил как смог
"О чем не пишут в книгах по Delphi" про winsock в лучшем виде посвящен целый раздел...

[=Zeus=]

"О чем не пишут в книгах по Delphi" про winsock в лучшем виде посвящен целый раздел...
Отличная книга, Антон Григорьев - хороший специалист.
У меня есть целый диск, который идет вместе с этой книгой, там отличные сорцы по Winsock. Вот:

Скачать файл CD.rar (http://dump.ru/file/3317275)

[DiSi]

как в Delphi в WebBrowser , определить что сайт делает редирект?)

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

[BlackSilver]

как в Delphi в WebBrowser , определить что сайт делает редирект?)

мб ктото знает как определить вооше данную страничку что в веб браузере? тогда б можно было сравнить ети значения с исходными, и понять был редирект или нет
C WebBrowser не сталкивался, но если именно редирект, то имеет смысл сравнить запрашиваемый урл перед и после загрузки страницы. Если сайт именно перепосылает, то они должны отличатся.

[=Zeus=]

как в Delphi в WebBrowser , определить что сайт делает редирект?)

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

Чтоб перейти на нужную страницу используй
WebBrowser1.Navigate('http:\\www.google.com');

Чтоб узнать что сейчас в адресной строке юзай
Caption:=WebBrowser1.LocationURL;

Не используй функции одна за одной, браузер попросту не успеет зайти на страницу и скажет что LocationURL пустая.

[DiSi]

Чтоб перейти на нужную страницу используй
WebBrowser1.Navigate('http:\\www.google.com');

Чтоб узнать что сейчас в адресной строке юзай
Caption:=WebBrowser1.LocationURL;

Не используй функции одна за одной, браузер попросту не успеет зайти на страницу и скажет что LocationURL пустая.
мм) а DocumentComplitle зачем?)
лан помог)) WebBrowser1.LocationURL етого не знал