» Вопросы по Delphi (все версии) - часть 3

RezchiK
Если я правильно понимаю что у тебя в программе написано, для того чтобы картинка выбиралась комбобоксом для него должен быть написан обработчик OnChange - вот он и вызывается (для случая если комбобокс называется ComboBox1)

Maks150988
Код: var
st: TSystemTime;
s1: string;
s2: string;
s3: string;
s: string;
begin
GetLocalTime(st);
Str(st.wHour, s1);
Str(st.wMinute, s2);
Str(st.wSecond, s3);
s := s1 + ':' + s2 + ':' + s3;

RomanTim
да мне не время нужно узнавать, а секундомер запустить. мне тут уже давали пример, однако надо отказаться от использования sysutils в проекте.



потом все-таки отыскал реализацию картинок в меню. в исходном примере блокнота bred окно создается кодом, а я гружу из ресурсов. поэтому видать напутал с хэндлами. менюшка сама прорисовывается в нужных местах, но картинки не грузятся в пункты. пожалуйста посмотрите. >>>

[more=Читать дальше..]

EDITOR.RES - битмап с номером 120


исходный код урезанный рабочий


Код: program Bred2b;

uses
Windows, Messages;

{$R EDITOR.RES}

var
MainWindow:hWnd;
MenuBmp, MenuBmp2:hBitmap;
MainMenu:hMenu;
PopMenu:array[0..7] of hMenu;
Instance: Longint;
PathName: array[0..260]of char;

const
{$I IDM.pas}
var
TCommand:packed array[1..7] of byte=
(id_new,id_odos,id_save,id_cut,id_copy,id_paste,id_undo);
SzMenu:array[1..bmps,0..31] of char;
Accnt:byte=0;


cp_m:integer=-1;


procedure OnMeasureItem(const lpmis:PMEASUREITEMSTRUCT);
var
r:TRect;
DC:hDC;
FileName: array[0..31]of char;
begin
if lpmis.CtlType=ODT_MENU then
begin
lstrcpy(FileName, SzMenu[lpmis.itemID]);
SetRectEmpty(r);
if FileName[0]<>#0 then
begin
DC:=GetDC(0);
DrawText(DC, FileName, lstrlen(FileName), r, DT_SINGLELINE or DT_CALCRECT or DT_LEFT);
ReleaseDC(0, DC);
if r.bottom<18 then r.Bottom:=18;
inc(r.right, 18);
end;
lpmis.itemWidth := r.Right;
lpmis.itemHeight := r.Bottom;
end;
end;

procedure OnDrawItem(const lpdis:PDRAWITEMSTRUCT);
var
clrPrevText, clrNewText : COLORREF;
r, r1 : TRect;
mode, i : integer;
FileName : array[0..31] of char;
ico : hIcon;
memDC : hDC;
Old : hGDIObj;
Flag : boolean;
begin
if lpdis.CtlType = ODT_MENU then
begin
i := lpdis.itemID;
ico := 0;
lstrcpy(FileName, SzMenu[i]);
if FileName[0]=#0 then exit;

CopyRect(r, lpdis.rcItem);
Flag:=(((lpdis.itemState and ODS_GRAYED) = 0) and((i <> id_tokoi8) and (i <> id_towin) and (i <> id_todos)) or ((lpdis.itemState and ODS_CHECKED) <> 0)) and not ((ico = 0)and(i >= 900));
if Flag then inc(r.Left, 19);
SetRect(r1, lpdis.rcItem.Left, lpdis.rcItem.Top, lpdis.rcItem.Left + 18, lpdis.rcItem.Bottom);
if (lpdis.itemState and ODS_SELECTED) <> 0 then
begin
if (lpdis.itemState and ODS_GRAYED) <> 0 then
clrNewText := COLOR_GRAYTEXT
else
begin
clrNewText := COLOR_HIGHLIGHTTEXT;
if Flag then
if (lpdis.itemState and ODS_CHECKED) <> 0 then
DrawEdge(lpdis.hDC, r1, BDR_SUNKENOUTER, BF_RECT)
else
DrawEdge(lpdis.hDC, r1, BDR_RAISEDINNER, BF_RECT);
end;
FillRect(lpdis.hDC, r, hBrush(COLOR_HIGHLIGHT + 1));
end
else
begin
if (lpdis.itemState and ODS_GRAYED) <> 0 then
begin
clrNewText := COLOR_GRAYTEXT;
end
else
begin
clrNewText := COLOR_MENUTEXT;
if Flag then
DrawEdge(lpdis.hDC, r1, BDR_RAISEDINNER, BF_RECT or BF_FLAT);
end;
FillRect(lpdis.hDC, r, hBrush(COLOR_MENU + 1));
end;
inc(r.left, 2);
if i >= 900 then
begin
if ico > 0 then
DrawIconEx(lpdis.hDC, lpdis.rcItem.Left, (lpdis.rcItem.Top + lpdis.rcItem.Bottom-16)div 2, Ico, 0,0,0, 0, DI_NORMAL) ;
end else
begin
if Flag then
begin
memDC:=CreateCompatibleDC(lpdis.hDC);
if i < 16 then
Old := SelectObject(memDC, MenuBmp)
else
begin
Old := SelectObject(memDC, MenuBmp2);
dec(i, 15);
end;
BitBlt(lpdis.hDC, lpdis.rcItem.Left+1, (lpdis.rcItem.Top + lpdis.rcItem.Bottom - 16) div 2, 16, 16, memDC, 16 * (i - 1), 0, SRCCOPY);
SelectObject(memDC, Old);
DeleteDC(memDC);
end;
end;
if not Flag then inc(r.Left, 19);
mode := SetBkMode(lpdis.hDC, TRANSPARENT);
if ((lpdis.itemState and ODS_GRAYED)<>0) and ((lpdis.itemState and ODS_SELECTED) = 0) then
begin
clrPrevText := SetTextColor(lpdis.hDC, GetSysColor(COLOR_BTNHILIGHT));
OffsetRect(r, 1, 1);
DrawText(lpdis.hDC, FileName, lstrlen(FileName), r, DT_SINGLELINE or DT_VCENTER);
OffsetRect(r, -1, -1);
SetTextColor(lpdis.hDC, GetSysColor(clrNewText));
end
else
clrPrevText := SetTextColor(lpdis.hDC, GetSysColor(clrNewText));
DrawText(lpdis.hDC, FileName, lstrlen(FileName), r, DT_SINGLELINE or DT_VCENTER or DT_LEFT);
SetBkMode(lpdis.hDC, mode);
SetTextColor(lpdis.hDC, clrPrevText);
end;
end;

function WindowProc(Window: HWnd; Message, WParam: Longint;
LParam: Longint): Longint; stdcall;
label
AssHole;
begin
case Message of
WM_MEASUREITEM:OnMeasureItem(PMEASUREITEMSTRUCT(lParam));
WM_DRAWITEM:OnDrawItem(PDRAWITEMSTRUCT(lParam));
end;
WindowProc := DefWindowProc(Window, Message, WParam, LParam);
end;

procedure MenuInit;
var
m__:UINT;
st:array[0..31] of char;

procedure AddOwnerDraw(const a,b:uint);
var
m__:integer;
begin
ModifyMenu(PopMenu[a], b, MF_BYCOMMAND or MF_OWNERDRAW,
b, nil);
for m__:=0 to lstrlen(SzMenu[b])-1 do
if (SzMenu[b][m__]='&')and(SzMenu[b][m__+1]<>'&') then
begin
inc(Accnt);
break;
end;
end;

begin
MainMenu:=GetMenu(MainWindow);
for m__:=0 to 7 do
PopMenu[m__]:=GetSubMenu(MainMenu, m__);
for m__:=1 to bmps do
begin
GetMenuString(MainMenu, m__, st, SizeOf(st), MF_BYCOMMAND);
lstrcpyn(SzMenu[m__], st, SizeOf(SzMenu[m__]));
end;
AddOwnerDraw(0,id_new);
AddOwnerDraw(0,id_odos);
AddOwnerDraw(0,id_save);

AddOwnerDraw(1,id_undo);
AddOwnerDraw(1,id_cut);
AddOwnerDraw(1,id_copy);
AddOwnerDraw(1,id_paste);
AddOwnerDraw(1,id_del);

AddOwnerDraw(3,id_view);
AddOwnerDraw(3,id_print);

AddOwnerDraw(4,id_find);
AddOwnerDraw(4,id_replace);

ModifyMenu(PopMenu[5], id_towin, MF_BYCOMMAND or MF_OWNERDRAW or MF_MENUBARBREAK, id_towin, nil);
for m__:=0 to lstrlen(SzMenu[id_towin])-1 do
if (SzMenu[id_towin][m__]='&')and(SzMenu[id_towin][m__+1]<>'&') then
begin
inc(Accnt);
break;
end;
AddOwnerDraw(5,id_tokoi8);
AddOwnerDraw(5,id_todos);
AddOwnerDraw(7,id_help);
end;




procedure WinMain;
var
Message: TMsg;
SI: TStartupInfo;
WindowClass: TWndClassEx;
begin
Instance:=GetModuleHandle(nil);
FillChar(WindowClass,SizeOf(TWndClassEx),0);
WindowClass.cbSize:= SizeOf(TWndClassEx);
WindowClass.lpfnWndProc:= @WindowProc;
WindowClass.hInstance := Instance;
WindowClass.lpszMenuName:= PChar(1);
WindowClass.lpszClassName:= 'BRED by mitvoh';
if RegisterClassEx(WindowClass) = 0 then
if RegisterClass(PWNDCLASS(@WindowClass.style)^) = 0 then Halt(255);

MainWindow := CreateWindowEx(0,
'BRED by mitvoh',
PathName,
DS_CENTER or WS_EX_CLIENTEDGE,
integer(cw_UseDefault),
integer(cw_UseDefault),
integer(cw_UseDefault),
integer(cw_UseDefault),
0,
0,
Instance,
nil);
MenuInit;

MenuBmp:=LoadImage(Instance, PChar(120), IMAGE_BITMAP, 0, 0, LR_LOADMAP3DCOLORS);

SI.cb:=sizeof(TStartupInfo);
GetStartupInfo(SI);
if SI.dwFlags and STARTF_USESHOWWINDOW = 0 then
SI.wShowWindow := SW_SHOWDEFAULT;



ShowWindow(MainWindow, SI.wShowWindow);

repeat
if GetMessage(Message, 0, 0, 0) then
begin
TranslateMessage(Message);
DispatchMessage(Message);
end else break;
until false;

DeleteObject(MenuBmp);
DeleteObject(MenuBmp2);


Halt(Message.wParam);
end;

begin
WinMain;
end.

Ну, вот и у меня вопросик появился, бьюсь уже несколько часов- не получается.
Тема для меня новая, поэтому прошу не пинать.

Есть функция:

function get_dog_num(const subacct_id: WideString): WideString;
Результат возвращает в кодировке UTF-8

Мне нужно прописать ее в dll, делаю так:

function get_dog_num (AccNo, UserName, Password:ShortString): ShortString; stdcall;
var
SoapDM : TdmSoap;
begin
SoapDM := TdmSoap.Create(nil);
with SoapDM do
try
htSubAcct.HTTPWebNode.UserName := UserName;
htSubAcct.HTTPWebNode.Password := Password;
Result:=(htSubAcct as subacctPortType).get_dog_num(AccNo);
finally
SoapDM.Free;
end;
end;

Соответственно, в вызывающем приложении делаю так:

function get_dog_num (AccNo, UserName, Password:ShortString): ShortString; stdcall; external 'soapfunc.dll' name 'get_dog_num';

{$R *.DFM}

procedure TCashRegForm.btnInetCheckPrintClick(Sender: TObject);
var
AccNo, UserName, Password: ShortString;
begin
UserName:='123123';
Password:='123213';
AccNo:=edtAccNo.Text;
memResult.Lines.Clear;
try
memResult.Lines.Add(strpas(get_dog_num(AccNo, UserName, Password)));
except
on E:Exception do memResult.Lines.Add(e.Message);
end;

Получаю Invalid pointer operation. Sharemem использовать нежелательно, при использовании pcchar непонятно как его коонвертировать в WideString и наоборот.

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

AntonVA1
Для WideString есть PWideChar (в С - LPWSTR)
Только есть одно но - если ты вернешь указатель на строку, которая описана как локальная в функции, то прочитать ее не успеешь - область кода где она живет закончилась. Я у себя в дллке модуле объявлял переменную в модуле, писал в нее результат, и возвращал указатель на нее.
Это не совсем красиво и правильно, но если вызывающий код будет у себя сохранять для дальнейшего использования содержимое строки, а не указатель, и не дергать функцию одновременно из нескольких потоков (это можно обойти через threadvar), то работать должно.

Maks150988
Блин, а подумать чуть вообще не бывает?
d := ("GetTickCount сейчас" - "GetTickCount раньше") div 1000 - разница времени в секундах
как div и mod дальше использовать тоже разжевать или догадаешься?

RomanTim
Спасибо за ответ, но я туго соображаю в этой части. А как ты бы написал этот код?

RomanTimу мнея маленько по другому, я в комбобоксе выбираю картинку и жму кнопку просмотра
procedure TFGall.Button1Click(Sender: TObject);//Просмотр
begin
if
FGall.ComboBox1.ItemIndex=0
then
FGall.Image2.Picture.LoadFromFile('1.bmp');
if
FGall.ComboBox1.ItemIndex=1
then
FGall.Image2.Picture.LoadFromFile('2.bmp');
end;
procedure TFGall.Button3Click(Sender: TObject); //Следующий
begin
if ComboBox1.ItemIndex < ComboBox1.Items.Count - 1
then
begin
ComboBox1.ItemIndex := ComboBox1.ItemIndex + 1;
// ComboBox1.Change(nil); так как компилятор руггается на Change
end;
end;

procedure TFGall.Button4Click(Sender: TObject); //пердыдущий
begin
if ComboBox1.ItemIndex > 0 then begin
ComboBox1.ItemIndex := ComboBox1.ItemIndex - 1;
//ComboBox1Change(nil); так как компилятор руггается на Change
end;
end;

Здраствуйте. Помогите пожалуйста решить такую задачку:
Нужно отобразить на форме все изображения хранящиеся в определенной папке, причем они имеют разные размеры и должны встать так, чтобы использовать свободное пространство по максимуму.
Собственно часть этой задачи я решил без проблемм, осталась одна заморочка: Как использовать свободное место на форме по максимуму?
На данный я создаю массив из изображений, кладу их на форму после выбора директории и если они не влазеют по ширине я прибавляю примерно так: .Top[i]:=.Top[i-1]+.height[i], а .left = 0; Но есть изображения которые меньше текущего(i-изображения) и которые влезут туда по ширине, но они пока не загружены.

Добавлено:
Поправка: .Top[i]:=.Top[i-1]+.height[i-1], а .left = 0

RomanTim
спасибо. просто я ночью уже не сообразил.

AntonVA1
В dll-ке делаешь так:
var
resstr: WideString;

function get_dog_num (AccNo, UserName, Password: PWideChar): PWideChar; stdcall;
...
resstr:=(htSubAcct as subacctPortType).get_dog_num(AccNo);
Result := PWideChar(resstr);
....
end;

RezchiK
Ну тогда вызывай не ComboBox1Change(nil), а Button1Click(nil) - то есть тот метод, в котором прописана логика отображения картинки в зависимости от состояния комбобокса

vladk1973

Цитата:

Интересный ответ.
Однако ты умалчиваешь о размере самих BPL в C:\WINDOWS\SYSTEM32
Например vcl60.bpl = 1295k
А без нее твоя чудо программка, даже пустая на 10к - работать не будет

Тоже интересный ответ. Но ты забываешь об объеме операционной системы и DLL в C:\WINDOWS\SYSTEM32 .
Например shell32.dll = 8471k
А без неё многие чудо программки неработают, даже если инсталлируются с виндой и никогда не запускаются. Да буде известно что BPL - это DLL с расширенным специфическим ресурсом. Так что если говорить о объеме и стандартах, то на 1 гигабайт Microsoft, по идее можно отвести 10 мегобайт VCL.

Естественно, что не на каждом компе имеется, и я раньше думал - ну нестандарт, значит вариант не устраивает. Но идёт жизнь, мои стандартные программули пользую только я сам, а компа где нет vcl60.bpl я не встречал. Так что пересмотри довод Borland я уважаю не меньше чем Microsoft. А вот MFC-шной дряни у меня полно во всех директориях, хотя вроде не пользую.

Цитата:

компа где нет vcl60.bpl я не встречал

Представьте себе у меня такой комп. И я готов отказаться почти от любой проги если в дистрибутиве с ней не идут все нужные нестандартные библиотеки. А это значит, что размер дистрибутива все равно должен быть 1305Кб, а не 10Кб. ИМХО использование "Build with runtime pakages" имеет смысл если:
-прога работает с dll в которой тоже есть формы;
-дистрибутив состоит из нескольких экзешников с формами.

RomanTim
AntonVA1
В общем виде - это не стандарт:

Цитата:

function get_dog_num (AccNo, UserName, Password: PWideChar): PWideChar; stdcall;

Пролистай файл Windows.pas ты не найдёшь ни одной функции возвращающей PChar или PWideChar. Происходит это потому, что DLL для строки выделяет память сама и другая DLL/EXE выделяет сама. Предсавь DLL выделила память я EXE освободила - это можно только с sharemem и то если версии компилера одинаковые. Так делать нельзя!!!!! Ай-яй-яй.

Делается это всегда так, в Value я даю готовую память для результата:

Код:
//В dll которая видит ToolsAPI и возвращает строку с опцией компилятора.
procedure OptionProc(const OptionName, Value: PChar;
MaxLen: Integer); safecall; //или - не важно stdcall;
var
S: string;
begin
if SubrealIDEServices <> nil then
begin
S := OptionName; //копирует имя из другого адресного пространства
S := SubrealIDEServices.CompilerOption(S); //запрашивает интерфейс ToolsAPI
StrLCopy(Value, PChar(S), MaxLen); //копирует результат в подготовленную память
end;
end;

//вызов из другого процесса
function IDE_CompilerOption(const OptionName: string): string;
var
Value: array[0..1023] of Char; //подготовим память в стэке,
//после работы она не нужна
begin
Result := '';
FillChar(Value, SizeOf(Value), 0);
OptionProc(PChar(OptionName), Value, SizeOf(Value)-1);
Result := PChar(@Value);
end;

delover

Цитата:

Тоже интересный ответ. Но ты забываешь об объеме операционной системы и DLL в C:\WINDOWS\SYSTEM32 .
Например shell32.dll = 8471k

Не понял, о чем речь. Человек сокрушался про объем exe, ты присоветовал компилить с опцией "Build with runtime packages", типа размер меньше. Ну ясно, что меньше, да только ему еще эти самые runtime packages придется вместе с маленькой exe носить, тем самым увеличивая совокупный объем инсталлируемого софта. Как в том анекдоте про супер-наручные часы с чемоданом батареек впридачу.
А при чем тут библиотеки операционной системы?


Цитата:

Да буде известно что BPL - это DLL с расширенным специфическим ресурсом.

О, великий, поучите меня создавать BPL


Цитата:

Так что если говорить о объеме и стандартах, то на 1 гигабайт Microsoft, по идее можно отвести 10 мегобайт VCL.

Цитата:

Естественно, что не на каждом компе имеется, и я раньше думал - ну нестандарт, значит вариант не устраивает.

Да все устраивает, мы что тут - спорим? Предмета спора я не вижу. Я сам компилировал большой банковский проект с "Build with runtime packages", ибо один раз инсталлируется на компьютер, записываются BPL, а потом через интернет проект постоянно обновляется - просто заменой маленького EXE и маленьких BPL. Экономится трафик, время и нервы. А для утилит и всякого "мелкого" одноразового софта любые дополнительные библиотеки - зло.


Цитата:

Но идёт жизнь, мои стандартные программули пользую только я сам, а компа где нет vcl60.bpl я не встречал.

Я встречал. Поверь - их очень много



Цитата:

А вот MFC-шной дряни у меня полно во всех директориях, хотя вроде не пользую.

Да, этого добра хватает, не забудь еще runtime библиотеки VB, FoxPro ну и там, по мелочи...


Цитата:

Предсавь DLL выделила память я EXE освободила - это можно только с sharemem и то если версии компилера одинаковые. Так делать нельзя!!!!! Ай-яй-яй.

Если вместо DLL использовать как раз BPL, то формально можно, хотя я бы не рекомендовал


Цитата:

Делается это всегда так, в Value я даю готовую память для результата

+1.
Господа, прежде чем программить и спрашивать, "как?", может почитаем исходники Delphi, или хотя бы подумаем, почему так "забавно" декларированы функции WinApi?

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

Кто нибуть может порекомендовать компонент для импорта даных с приложения в XLS-файл (Exel), но чтобы и OpenOffice 2.2 смог этот файл открыть нормально без кряказябликов!

RomanTim, спсибо за совет, всё получилось

Теперь в БД столкнулся с таким косяком-запись из поля memo в DBGird

Цитата:

if Memo1.Lines.Count>0 then
begin
TBlodField(DataModule1.TableGlavn_1.Fields[8]).BlodType:=ftMemo
TBlodField(DataModule1.TableGlavn_1.Fields[8]).Assign(Memo1.Lines);
end;

ругается комнилятор на не объявленный TBlodField, чем его объявить если не секрет)))

RezchiK, TBlobField.

vladk1973

Цитата:

Да все устраивает, мы что тут - спорим? Предмета спора я не вижу. Я сам компилировал большой банковский проект с "Build with runtime packages", ибо один раз инсталлируется на компьютер, записываются BPL, а потом через интернет проект постоянно обновляется - просто заменой маленького EXE и маленьких BPL. Экономится трафик, время и нервы. А для утилит и всякого "мелкого" одноразового софта любые дополнительные библиотеки - зло.

+1
Сиё основное, и бесспорно. Были выше рассуждения про целеобразность BPL, с радостью процитировал, так как лучше не скажешь.


Цитата:

Цитата:Но идёт жизнь, мои стандартные программули пользую только я сам, а компа где нет vcl60.bpl я не встречал.
Я встречал. Поверь - их очень много

Мы тут не спорим. Прочитай внимательно, но я поясню про какие компьютеры говорю. Я имею ввиду компьютеры с которыми сам реально имею дело. Это мой рабочий компьютер и мой домашний. На компы сослуживцев не лезу - дело администратора. Когда помогаю знакомым - им нужно установить Файн Райдер, это далеко не мои маленькие проги. Поверь о великий учитель я тоже предполагаю, что такие компьютеры есть. Давай отделим мух от котлет. Те компьютеры которые без BPL по жизни нуждаются в твоих программах? Ты эту галочку не используешь потому, что хочешь обязательно установить свою прогу куда ни попадя? Или ты всё таки слышал такое слово ЗАКАЗЧИК?


Цитата:

Цитата:Да буде известно что BPL - это DLL с расширенным специфическим ресурсом.

О, великий, поучите меня создавать BPL

Я делал BPL которым не нужно даже VCL/RTL и они были взаимосвязаны. Это ничем не отличается от DLL, только появляются свои прелести. Поучить?


Цитата:

Не понял, о чем речь. Человек сокрушался про объем exe

Речь про то, что чел пишет на API, и как основное приемущество приводит размер exe. Так я и объясняю что это "приемущество" достигается одной галочкой. А всю суть ты сам сказал в начале поста. Можно только добавить - если Вы делаете EXE без использования BPL, то совершенно очевидно, что Вам без опасения можно использовать Anti DeDe. Чтобы всякие ламеры не могли преспокойно взламывать Вашу прогу. Я так понимаю - почти все не используют BPL и не разу не слышал что кому то надо Anti DeDe. Чтобы не быть пустомелей, пожалуйте [more=Anti DeDe UnDebug: накрапал за вечер undeb32.dpr]
Код: [no]program undeb32;

{$APPTYPE CONSOLE}

{%File 'build.bat'}

uses
Windows,
SysUtils,
Classes,
TlHelp32,
ImageHlp,
JclPeImage;

{$R *.res}

const
PackageInfoResName = 'PACKAGEINFO';

var
DebugPause: Boolean = False;
ExeFile: string = '';
ReportFile: string = '';
SetChecksum: Boolean = False;
ShowingFlag: Boolean = False;
ShowMessages: Boolean = True;
UseReport: Boolean = False;

procedure ShowCopyright;
begin
if ShowingFlag then Exit;
ShowingFlag := True;
Writeln('UNDEB32 (C) subreal.PIN Check Utility. Version 1.03 13-04-2007');
Writeln('Copr. 2006-2007 Roman Silin. All Rights Reserved. Freeware Version');
Writeln;
end;

procedure ShowUsage;
begin
ShowCopyright;
Writeln('Usage: UNDEB32 exefile [/p | /n] [/c | /m [reportfile]]');
end;

procedure Pause;
begin
if not DebugPause then exit;
if not ShowMessages then exit;
Writeln('Press enter...');
Readln;
end;

procedure ShowError(const Msg: string; const Args: array of const);
begin
ShowUsage;
Writeln;
Writeln('Error: ', Format(Msg, Args));
Pause;
Halt(0);
end;

procedure GetParameters;
var
I: Integer;
S: string;
begin
ExeFile := ExpandFileName(ParamStr(1));
I := 2;
repeat
S := ParamStr(I);
if S = '' then Break;
if (S[1] <> '/') and (S[1] <> '-') then
ShowError('Unknown parameter "%s"', [S]);
Delete(S, 1, 1);
if S = '' then Break;
case UpCase(S[1]) of
'P': DebugPause := True;
'N': ShowMessages := False;
'C': SetChecksum := True;
'M': UseReport := True;
end;
Inc(I);
if UseReport then
begin
ReportFile := ParamStr(I);
if ReportFile = '' then
ReportFile := ChangeFileExt(ExeFile, '.rep') else
if ExtractFileName(ReportFile) = ReportFile then
ReportFile := ExtractFilePath(ExeFile) + ReportFile else
ReportFile := ExpandFileName(ReportFile);
Break;
end;
until 0 <> 0;
if not FileExists(ExeFile) then
ShowError('File not found "%s"', [ExeFile]);
end;

{$IFDEF REGION}{$REGION ' [ TJclPeBorInfo ] '}{$ENDIF}
type
TJclPeBorInfoProgress = procedure(Position: DWORD);
TJclPeBorInfo = class(TJclPeBorImage)
private
FBaseOfCode: DWORD;
FEntryImport: DWORD;
FExcludeUnits: TStringList;
FMainUnit: string;
FOnProgress: TJclPeBorInfoProgress;
FPackageInfoData: DWORD;
FPackageInfoSize: DWORD;
FSearchResult: TStringList;
FShortString: Boolean;
FTempContains: TStringList;
function GetFileName: TFileName;
function GetOffset(OffseToData: DWORD): DWORD;
function GetSearchCount: Integer;
function GetSearchData(Index: Integer): DWORD;
function GetSearchNames(Index: Integer): string;
procedure SetFileName(const Value: TFileName);
protected
procedure ClearSearch;
function DoSearch(const StartSearch, EndSearch: DWORD): Boolean;
public
constructor Create(ANoExceptions: Boolean = False); override;
destructor Destroy; override;
function CodeSearch: Boolean;
function HasPackages: Boolean;
function PackageInfoSearch: DWORD;
property BaseOfCode: DWORD read FBaseOfCode;
property EntryImport: DWORD read FEntryImport;
property ExcludeUnits: TStringList read FExcludeUnits;
property FileName: TFileName read GetFileName write SetFileName;
property MainUnit: string read FMainUnit;
property OnProgress: TJclPeBorInfoProgress read FOnProgress write FOnProgress;
property PackageInfoData: DWORD read FPackageInfoData;
property PackageInfoSize: DWORD read FPackageInfoSize;
property SearchCount: Integer read GetSearchCount;
property SearchData[Index: Integer]: DWORD read GetSearchData;
property SearchNames[Index: Integer]: string read GetSearchNames;
end;

{ TJclPeBorInfo }

procedure TJclPeBorInfo.ClearSearch;
var
I: Integer;
begin
FMainUnit := '';
for I := 0 to FTempContains.Count - 1 do
FreeMem(Pointer(FTempContains.Objects[I]));
FTempContains.Clear;
FSearchResult.Clear;
end;

function TJclPeBorInfo.CodeSearch: Boolean;
begin
FShortString := True;
Result := DoSearch(BaseOfCode, EntryImport);
end;

constructor TJclPeBorInfo.Create(ANoExceptions: Boolean);
begin
inherited Create(ANoExceptions);
FExcludeUnits := TStringList.Create;
FSearchResult := TStringList.Create;
FTempContains := TStringList.Create;
end;

destructor TJclPeBorInfo.Destroy;
begin
ClearSearch;
FTempContains.Free;
FSearchResult.Free;
FExcludeUnits.Free;
inherited Destroy;
end;

function TJclPeBorInfo.DoSearch(const StartSearch, EndSearch: DWORD): Boolean;

function DoTempContains: Integer;
var
I, L: Integer;
S: ShortString;
P: PShortString;
begin
Result := 0;
ClearSearch;
if FindResource(LibHandle, PackageInfoResName, RT_RCDATA) <> 0 then
begin
FTempContains.AddStrings(PackageInfo.Contains);
for I := 0 to FTempContains.Count - 1 do
if (PackageInfo.ContainsFlags[I] and ufMainUnit) <> 0 then
begin
FMainUnit := FTempContains[I];
Break;
end;
if FShortString then
for I := 0 to ExcludeUnits.Count - 1 do
begin
L := FTempContains.IndexOf(ExcludeUnits[I]);
if L >= 0 then FTempContains.Delete(L);
end;
for I := 0 to FTempContains.Count - 1 do
begin
S := FTempContains[I];
L := Length(S) + 1;
GetMem(P, L);
if FShortString then
P^ := S else
Move(PChar(FTempContains[I])^, P^, L);
FTempContains.Objects[I] := Pointer(P);
if Result < L then Result := L;
end;
end;
if MainUnit = '' then
FMainUnit := ChangeFileExt(ExtractFileName(FileName), '');
end;

var
I: DWORD;
J, L, M, Step: Integer;
P: Pointer;
A: Byte;
T, S: PShortString;
begin
Result := False;
M := DoTempContains;
P := RawToVa(0);
I := StartSearch + 2;
Inc(DWORD(P), I);
T := nil;
repeat
Step := 1;
A := Byte(P^);
if (A <> 0) and ((A < M) or not FShortString) then
for J := 0 to FTempContains.Count - 1 do
begin
S := Pointer(FTempContains.Objects[J]);
if FShortString then
L := Length(S^) else
L := StrLen(PChar(S));
if not CompareMem(P, @S^[0], L + 1) then Continue;
if FShortString then
FSearchResult.AddObject(S^, TObject(I)) else
FSearchResult.AddObject(PChar(S), TObject(I));
if (T = nil) then T := S else
if (T <> S) then
begin
FreeMem(T);
FTempContains.Delete(FTempContains.IndexOfObject(Pointer(T)));
T := S;
end;
Inc(Step, L);
Result := True;
if Assigned(FOnProgress) then
FOnProgress(I);
Break;
end;
Inc(I, Step); Inc(DWORD(P), Step);
until I >= EndSearch - 2;
if Assigned(FOnProgress) then
FOnProgress(EndSearch);
end;

function TJclPeBorInfo.GetFileName: TFileName;
begin
Result := inherited FileName;
end;

function TJclPeBorInfo.GetOffset(OffseToData: DWORD): DWORD;
var
I: Int64;
begin
I := DWORD(RvaToVa(OffsetoData)) -
DWORD(LoadedImage.MappedAddress);
Result := I;
end;

function TJclPeBorInfo.GetSearchCount: Integer;
begin
Result := FSearchResult.Count;
end;

function TJclPeBorInfo.GetSearchData(Index: Integer): DWORD;
begin
if (Index >=0) and (Index < SearchCount) then
Result := DWORD(FSearchResult.Objects[Index]) else
Result := 0;
end;

function TJclPeBorInfo.GetSearchNames(Index: Integer): string;
begin
if (Index >=0) and (Index < SearchCount) then
Result := FSearchResult[Index] else
Result := '';
end;

function TJclPeBorInfo.HasPackages: Boolean;
var
I: Integer;
begin
for I := 0 to ImportList.Count - 1 do
begin
Result := SameText(ExtractFileExt(
ImportList[i].Name), '.bpl');
if Result then Exit;
end;
Result := False;
end;

function TJclPeBorInfo.PackageInfoSearch: DWORD;
var
I: Integer;
SaveOnProgress: TJclPeBorInfoProgress;
begin
Result := 0;
SaveOnProgress := FOnProgress;
FOnProgress := nil;
FShortString := False;
if DoSearch(PackageInfoData, PackageInfoData + PackageInfoSize) then
begin
I := FSearchResult.IndexOf(MainUnit);
if I = 0 then
Result := SearchData[I];
end;
FOnProgress := SaveOnProgress;
end;

procedure TJclPeBorInfo.SetFileName(const Value: TFileName);
var
ResItem: TJclPeResourceItem;
begin
inherited FileName := Value;

//get start..end of Code
FBaseOfCode := GetOffset(StrToInt('$' +
HeaderValues[JclPeHeader_BaseOfCode]));
FEntryImport := GetOffset(Directories[
IMAGE_DIRECTORY_ENTRY_IMPORT].VirtualAddress);

//get start..end of PackageInfo
ResItem := ResourceList.FindResource(rtRCData, PackageInfoResName);
if ResItem <> nil then
begin
FPackageInfoData := GetOffset(ResItem.List[0].DataEntry.OffsetToData);
FPackageInfoSize := ResItem.List[0].DataEntry.Size - 1;
end else
begin
FPackageInfoData := 0;
FPackageInfoSize := 0;
end;
end;
{$IFDEF REGION}{$ENDREGION}{$ENDIF}

var
BorInfo: TJclPeBorInfo;
MemoryStream: TMemoryStream;
ReportList: TStringList;
SuccessOK: Boolean = False;

procedure LoadExeFile;
begin
MemoryStream := TMemoryStream.Create;
MemoryStream.LoadFromFile(ExeFile);
BorInfo := TJclPeBorInfo.Create;
BorInfo.FileName := ExeFile;
BorInfo.ExcludeUnits.Add('Options');
ReportList := TStringList.Create;
end;

procedure FreeExeFile;
begin
ReportList.Free;
BorInfo.Free;
MemoryStream.Free;
end;

function DoCheckSum: Boolean;
var
HeaderSum, CheckSum: DWORD;
ImageNtHeaders: PImageNtHeaders;
begin
Result := False;
CheckSum := 0;
ImageNtHeaders := CheckSumMappedFile(MemoryStream.Memory,
MemoryStream.Size, @HeaderSum, @CheckSum);
if ImageNtHeaders = nil then Exit;
ImageNtHeaders.OptionalHeader.CheckSum := CheckSum;
Result := True;
end;

procedure ShowStartEnd;
begin
ReportList.Clear;
with BorInfo do
ReportList.Add(Format('Base of code .. entry import: %x..%x' +
'; package info: %x..%x', [BaseOfCode, EntryImport,
PackageInfoData, PackageInfoData + PackageInfoSize]));
ReportList.Add('');
if not ShowMessages then Exit;
Writeln(ReportList[0]);
Writeln(ReportList[1]);
end;

procedure ShowProgress(Position: DWORD);
var
S, S1, T, U: string;
I: Integer;
begin
with BorInfo do
S := Format('Count: %d (%d%%)', [SearchCount,
(Position - BaseOfCode)*100 div (EntryImport - BaseOfCode)]);
if Position = BorInfo.EntryImport then
begin
T := '';
for I := 0 to BorInfo.SearchCount - 1 do
begin
U := BorInfo.SearchNames[I];
if (Length(U) < 4) and (U <> 'DB') then Continue;
if T <> U then
begin
if T <> '' then
ReportList.Add(Format('%s: %s', [T, S1]));
S1 := '';
T := U;
end;
if S1 <> '' then
S1 := S1 + ', ';
S1 := S1 + Format('%x', [BorInfo.SearchData[I]]);
end;
if T <> '' then
ReportList.Add(Format('%s: %s', [T, S1]));
ReportList.Add(S);
end;
if not ShowMessages then Exit;
Write(#13, S);
if Position = BorInfo.EntryImport then
Writeln;
end;

function UnDebugImage: Boolean;
const
IllegalChars = '"*<>?|';
var
I, J: Integer;
P: PShortString;
begin
{ Find names of code }
BorInfo.OnProgress := ShowProgress;
Result := BorInfo.CodeSearch;
if not Result then Exit;

{ Work }
Randomize;
for I := 0 to BorInfo.SearchCount - 1 do
begin
P := MemoryStream.Memory;
Inc(DWORD(P), BorInfo.SearchData[I]);
if (Length(P^) < 4) and (P^ <> 'DB') then Continue;
for J := 1 to Length(P^) do
P^[J] := Char(Random(221) + 33);
P^[Random(Length(P^)) + 1] :=
IllegalChars[Random(Length(IllegalChars)) + 1];
end;
end;

procedure UnDebugPackageInfo;
var
I, J, M: DWORD;
P: Pointer;
begin
{ Find names of package info }
M := BorInfo.PackageInfoSearch;
if M = 0 then Exit;

{ Store one name of package and find start }
P := MemoryStream.Memory;
Inc(DWORD(P), M - 6);
DWORD(P^) := 1;

{ Work }
Randomize;
for I := 1 to BorInfo.SearchCount - 1 do
begin
P := MemoryStream.Memory;
Inc(DWORD(P), BorInfo.SearchData[I]);
for J := 1 to Length(BorInfo.SearchNames[I]) do
begin
Byte(P^) := Byte(Random(221) + 33);
Inc(DWORD(P));
end;
Byte(P^) := $FF;
end;
end;

procedure ShowAndStoreFiles;
var
S, S1: string;
I, F: Integer;
begin
ReportList.Add('');
F := ReportList.Count;
if SetChecksum then
S := ChangeFileExt(ExeFile, '~.bak') else
S := ChangeFileExt(ExeFile, '.bak');
DeleteFile(S);
RenameFile(ExeFile, S);
MemoryStream.SaveToFile(ExeFile);
if SetChecksum then
S1 := 'checksum' else
S1 := Format('"%s"', [BorInfo.MainUnit]);
ReportList.Add(Format('Success %s. Copy to file "%s". Save "%s". OK', [
S1, ExtractFileName(S), ExtractFileName(ExeFile)]));
if ShowMessages then
for I := F to ReportList.Count - 1 do
Writeln(ReportList[I]);
if not UseReport then Exit;
DeleteFile(ReportFile);
ReportList.SaveToFile(ReportFile);
end;

{$IFDEF REGION}{$REGION ' [ UnkStart ] '}{$ENDIF}
function DequotedStr(const S: string): string;
var
P: Integer;
D: string;
begin
if (S <> '')and(S[1] = '"') then
begin
D := Copy(S, 2, MaxInt);
P := Pos('"', D);
if P > 0 then
SetLength(D, P-1) else
D := S;
Result := D;
end else
Result := S;
end;

function TermProcess(const FileName: string): Boolean;
const
TH32CS_SNAPPROCESS = $00000002;
var
SH: THandle;
TP: TProcessEntry32;
LID, PID: DWORD;
I: Integer;
ExeFile, S: string;
begin
Result := False;
if FileName = '' then Exit;
ExeFile := UpperCase(ExtractFileName(DequotedStr(FileName)));
SH := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
if Integer(SH) < 0 then Exit;
TP.dwSize := SizeOf(TProcessEntry32);
if not Process32First(SH, TP) then Exit;
PID := 0;
LID := 0;
for I := 0 to 999 do
begin
S := UpperCase(TP.szExeFile)+'[';
if Pos('[', S) <> 1 then
if Pos(ExeFile, S) > 0 then
begin
LID := PID;
PID := TP.th32ProcessID;
end;
if not Process32Next(SH, TP) then Break;
end;
if PID = 0 then Exit;
if (LID <> 0) and SameText(ExeFile, ExtractFileName(ParamStr(0))) then
PID := LID;
SH := OpenProcess(PROCESS_ALL_ACCESS, True, PID);
Result := TerminateProcess(SH, 0);
CloseHandle(SH);
end;

function GetFileVerValueName(const AFileName, AValueName: string): string;
var
S: string;
InfoSize, Wnd: DWORD;
VerBuf, P: Pointer;
VerSize: DWORD;
begin
Result := '';
// GetFileVersionInfo modifies the filename parameter data while parsing.
// Copy the string const into a local variable to create a writeable copy.
S := AFileName;
UniqueString(S);
InfoSize := GetFileVersionInfoSize(PChar(S), Wnd);
if InfoSize <> 0 then
begin
GetMem(VerBuf, InfoSize);
try
if not GetFileVersionInfo(PChar(S), Wnd, InfoSize, VerBuf) then
Exit;
if not VerQueryValue(VerBuf, '\VarFileInfo\Translation', P, VerSize) then
Exit;
S := Format('%.8x', [Integer(P^)]);
S := Format('\StringFileInfo\%s%s\%s',
[Copy(S, 5, 4), Copy(S, 1, 4), AValueName]);
if VerQueryValue(VerBuf, PChar(S), P, VerSize) then
Result:= PChar(P);
finally
FreeMem(VerBuf);
end;
end;
end;

function FindPrevProcess(const ExeFile: string): string;
const
TH32CS_SNAPPROCESS = $00000002;
var
SH: THandle;
TP: TProcessEntry32;
TM: TModuleEntry32;
PID: DWORD;
I: Integer;
S: string;
begin
Result := '';
if ExeFile = '' then Exit;
SH := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
if Integer(SH) < 0 then Exit;
TP.dwSize := SizeOf(TProcessEntry32);
if not Process32First(SH, TP) then Exit;
PID := 0;
for I := 0 to 999 do
begin
S := UpperCase(TP.szExeFile);
if SameText(ExeFile, S) then
PID := TP.th32ParentProcessID;
if not Process32Next(SH, TP) then Break;
end;
if PID = 0 then Exit;
if not Process32First(SH, TP) then Exit;
S := '';
for I := 0 to 999 do
begin
if PID = TP.th32ProcessID then
begin
S := TP.szExeFile;
Break;
end;
if not Process32Next(SH, TP) then Break;
end;
CloseHandle(SH);
SH := CreateToolhelp32Snapshot(TH32CS_SNAPMODULE, PID);
if Integer(SH) < 0 then Exit;
TM.dwSize := SizeOf(TModuleEntry32);
if not Module32First(SH, TM) then Exit;
for I := 0 to 999 do
begin
if SameText(TM.szModule, S) then
begin
Result := TM.szExePath;
Break;
end;
if not Module32Next(SH, TM) then Break;
end;
end;

function GetPrevVersionName(const AValueName: string;
var AProcessName: string): string;
begin
AProcessName := FindPrevProcess(UpperCase(
ExtractFileName(ParamStr(0))));
if AProcessName <> '' then
Result := GetFileVerValueName(AProcessName,
AValueName) else
Result := '';
end;

procedure GetVirtualProcess(var AValue: string;
const AProcessName: string);
var
PeImage: TJclPeImage;
LibItem: TJclPeImportLibItem;
I, J: Integer;
begin
PeImage := TJclPeImage.Create;
try
PeImage.FileName := AProcessName;
PeImage.TryGetNamesForOrdinalImports;
for I := 0 to PeImage.ImportList.Count - 1 do
begin
LibItem := PeImage.ImportList[i];
if not SameText(Copy(LibItem.Name, 1, 8), 'kernel32') then Continue;
for J := 0 to LibItem.Count - 1 do
if SameText(Copy(LibItem.Items[J].Name, 1, 8), 'virtualp') then
begin
AValue := '';
Exit;
end;
end;
finally
PeImage.Free;
end;
end;

function UnkStart(const AValueName: string): string;
var
S: string;
begin
S := GetPrevVersionName(AValueName, Result);
if (S <> '') and (Result <> '') then
GetVirtualProcess(S, Result);
if (S = '') and (Result <> '') then
begin
Result := UpperCase(ExtractFileName(Result));
S := Copy(ChangeFileExt(Result, ''), 3, MaxInt);
if (Length(S) = 1) and (S[1] <> 'R') and
(Copy(Result, 1, 2) <> 'FA') then Exit;
TermProcess(Result);
Halt;
end;
end;
{$IFDEF REGION}{$ENDREGION}{$ENDIF}

begin
UnkStart('ProductName');
if (ParamCount < 1) or SameText(ParamStr(1), '/p') then
begin
ShowUsage;
DebugPause := ParamCount > 0;
Pause;
exit;
end;
GetParameters;
if ShowMessages then
ShowCopyright;
try
LoadExeFile;

if SetChecksum then
SuccessOK := DoCheckSum else
begin
if not BorInfo.HasPackages then
ShowStartEnd else
ShowError('Build with runtime packages', []);
if BorInfo.PackageInfoSize <> 0 then
SuccessOK := UnDebugImage else
ShowError('Package info not found', []);
if SuccessOK then
UnDebugPackageInfo;
end;

if SuccessOK then
begin
BorInfo.FreeLibHandle;
ShowAndStoreFiles;
end else
ShowError('File already undebug', []);

FreeExeFile;
except
on E: Exception do
ShowError(E.Message, []);
end;

Pause;
end.[/no]

Может кто знает как сделать вот такую хитрожёлтую вещь:
У меня в табилце первое поле, это "номер заказа"всё вводится вот таким макаром:

Цитата:

procedure TFZakaz.Button2Click(Sender: TObject);
begin
// добавляем пустую запись в набор Glavn
DataModule1.TableGlavn1.Insert;
DBGrid1.Fields[0].AsInteger;
DataModule1.TableGlavn1.Fields[1].AsInteger:=StrToInt(Edit1.Text); // номер заказа
DataModule1.TableGlavn1.Fields[2].AsString:=Edit2.Text; // заказчик
DataModule1.TableGlavn1.Fields[3].AsString:=Edit3.Text; // Адрес
DataModule1.TableGlavn1.Fields[4].AsDateTime:=StrToDateTime(MaskEdit1.Text);// дата заказа
DataModule1.TableGlavn1.Fields[5].AsDateTime:=StrToDateTime(MaskEdit2.Text);// дата изготовления
DataModule1.TableGlavn1.Fields[6].AsInteger:=StrToInt(Edit4.Text); // стоимость
DataModule1.TableGlavn1.Fields[7].AsString:=Edit5.Text; // название изделия
DataModule1.TableGlavn1.Fields[8].AsString:=Edit6.Text;
DataModule1.TableGlavn1.Fields[9].AsString:=label11.Caption;
DataModule1.TableGlavn1.Fields[10].AsString:=label12.Caption;
edit1.Clear;
edit2.Clear;
edit3.Clear;
MaskEdit1.Clear;
MaskEdit2.Clear;
edit4.Clear;
edit5.Clear;
edit6.Clear;
label11.Caption:='';
label12.Caption:='';
end;

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

И вот такой ещё квейшенс...как это можно сделать: я задаю номер заказа и прога выдаёт мне всё по этому заказу(нужно для печати). Зарание благодарю

delover
Как я понял UnDebug находит ресурс с названием PACKAGEINFO и записывает туда всякую билиберду. А что она еще делает? Мне пока не хватает сил разобратся в этом самому. Кстати может стоит просто удалять ресурсы PACKAGEINFO и DVCLAL?

RezchiK

Цитата:

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

если не хочешь связываться с обработкой исключений при инсерте уже cуществующего номера - ПЕРЕД инсертом необходимо САМОМУ проверить не существует ли он уже. Например выполнив SELECT-запрос к этой же таблице. Если вернёт 0 записей, то всё отлично, если 1 или больше(гыы) - значит такой номер уже существует.


Цитата:

как это можно сделать: я задаю номер заказа и прога выдаёт мне всё по этому заказу(нужно для печати)

перейти на нужную запись с пом. метода Locate или, опять же, в отдельном t[xxx]Query выполнить SELECT-запрос

Frodo_Torbins
Прога делает вот какую вещь:
1. На расстоянии от BASE_OF_CODE, до этого места искать имена нельзя. До точки ENTRY_IMPORT, после этой точки идут другие имена и все ресурсы. Так вот на этом расстоянии находит имена UNIT-ов (для экзешника без BPL это бесполезная отладочная инфа). И как ты правильно заметил заполняет билибердой.
2. PACKAGEINFO заполняет билибердой, но только после первого имени программы, так что корректность PACKAGEINFO остаётся.

Что это даёт?
1. Когда DeDe пытается записать файлы форм, они содержат некорректные символы которые нельзя использовать в именах файлов. В этот момент она выводит ошибку и прекращает дамп.
2. Она не находит связей между модулями Classes и Classes. Теперь для неё это разные модули. Крыша у неё начинает ехать основательно. Когда я смотрю процедуры то программа выполняет 0000 - в асме это add ax...
3. DeDe в этом случае обязательно пытается запустить программу когда я нажымаю кнопку Proccess. Без этой кнопки я вообще ничего не увижу. Так вот DeDe запускает мою защищённую прогу обязательно. Но только незадача - у меня в секции initialization стоит процедура KillUnknownStarter. Она смотрит Copyright запустившей программы и если копирайта нет, то она делает Kill запустившего процесса вместе с собой. В результате, когда мы в DeDe нажимаем кнопку Proccess, то программа захлапывается. Так что DeDe становится совершенно бесполезным инструментом.
4. В добавок в бат файле имеется StripReloc и UPX. Так что взломать проу жутко проблемматично.

Я просто полагаю у всех нормальных программистов есть JCL? Без него вообще смысла работать нет, да и он весь в исходниках, бояться нечего. Так он её использует, вот и все нюансы. Да забыл (Удалено: KillUnknownStarter], уже находится в коде в предыдущем посте).

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


Цитата:

Кстати может стоит просто удалять ресурсы PACKAGEINFO и DVCLAL?

DVCLAL Удалять не рекомендую. А утилиту по удалению PACKAGEINFO мне писать лень. Удалять можно без проблемм, но это же ручками, а я что дурак ручками? Кстати в случае удаления PACKAGEINFO DeDe становится "хитрее". Так что не стоит пачькаться, d PACKAGEINFO остаётся исходное имя программы, на тот случай если её переименовали, то имя можно узнать. Попробуй потестить, думаю повеселишься на славу.

jONES1979

Цитата:

если не хочешь связываться с обработкой исключений при инсерте уже cуществующего номера - ПЕРЕД инсертом необходимо САМОМУ проверить не существует ли он уже. Например выполнив SELECT-запрос к этой же таблице. Если вернёт 0 записей, то всё отлично, если 1 или больше(гыы) - значит такой номер уже существует.

Не напрвавишь на путь истины, а то у меня башка уже не соображает, так как я как истинный студент весь семестр работал и естественно забивал на учёбу, и вот курсач и все лабы за пару дней делаю, а это остался последний штрих)))

delover:
Цитата:

DVCLAL Удалять не рекомендую.

К чему это может привести?
И еще. Стоит ли так опасаться DeDe, ведь он не показывает содержимое процедур и функций (хотя информации всеже дает много). И новые версии делфей вроде не понимает.

P.S. А можно ли заставить стандартный компилятор не добавлять лишней информации?

delover
Интересная инфа. Респект.
Только мне она вряд ли будет полезна, ибо я не занимаюсь более коммерческим софтом. Хотите взломать мои проги - пожалуйста, а будете поумнее, то просто попросите у меня исходники

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

а почему действительно не рекомендуется удалять DVCLAL? Я потом дочищаю экзешник после компиляции. Выигрыш в размере увеличивается еще на 5-7 кб.

Цитата:

а почему действительно не рекомендуется удалять DVCLAL?

Это только навскидку я приведу явно зависимые от DVCLAL функции. Правда этот набор ещё зависит от версии Delphi.

1. TSession.InitializeBDE;
2. TSQLConnection.DoConnect;
3. TDataSource.Create(AOwner: TComponent);
4. TBaseSocket.Create(AOwner: TComponent);
5. TSoapConnection.Create(AOwner: TComponent);
6. TDBCtrlGridLink.Create(DBCtrlGrid: TDBCtrlGrid);
7. TDSTableProducerEditor.Create(DSTableProducer: TDSTableProducer);
8. TBasePageProducer.Create(AOwner: TComponent);
9. TCustomWebDispatcher.Create(AOwner: TComponent);
10. Весь Decision Cube.
11. TConnectionBroker.Create(AOwner: TComponent);
12. TDispatchConnection.Create(AOwner: TComponent);
13. TLocalConnection.Create(AOwner: TComponent);
...

Это я начесал только с одной версии Delphi и только явно зависимые. У меня прога которая не использовала этих функций перестаёт работать.
1. Но перестала работать это довод номер 1. Откажись для данной версии от стандартных компонентов и все дела.
2. Довод номер 2 - это то, что всё же как никак рас защищают этим в Delphi свои технологии значит это идентификатор продукта и авторское право. Мне не по пути с нарушителями авторского права. У меня лицензионные Windows, Delphi 7,2005,2006, MSSQL и даже Beyond Compare 2. И дома и на работе. Пусть прикольные хипари которые это всё делали получат свои законные деньги и авторские права.
3. На вскидку DVCLAL занимает 16 байт, в ручную удалять его из-за 16-и байт - это геморой.
4. Эта штука не только стандарт Delphi. И не имеет отношения к "отладочной информации и взлому программ". Проще удалить копирайты и номера версии из программы. Это будет корректнее.
5. Б$%^ля, переживать из-за 16 байт и не сократить имя класса, количество классов, не сократить строки сообщений для пользователя - это уже будет не последовательно.
6. Времена когда мы программисты бились за 16 байт прошли. Слава тебе господи в продаже уже винты на 1 террабайт.
7. System Commander 7, замечательный мэнеджер мультизагрузки. После инсталляции занимает ~30мб. Я бы очень хотел, чтобы на моём 400гб винте он занимал хотябы 300мб и был менее убогим, но более безопасным. Я от него отказался, - ему просто не вырасти, а Вы мне по 16 байт. Ну убого нарушать авторство ради того, что не является даже показателем для тех кто в авторстве не смыслит, а размер желал бы больший.

Добавлено:
ЗЫ: Равносильно тому, чтобы тошнотик или дистрофик, чтобы ещё больше похудеть вырезал себе печень.

vladk1973

Цитата:

Интересная инфа. Респект.

Всегда пожалуйста. А прога действительно неплохая - там стиль консольного приложения правильный.

Добавлено:
Да и забыл

Цитата:

Хотите взломать мои проги - пожалуйста, а будете поумнее, то просто попросите у меня исходники

У меня по другому. Хотите взломать проги - фиг Вам, нех$%^ лазить в бин, буть человеком, наберись смелости и спроси текст, или как сделать. Тоже отдам текст и буду рад что юзер не зависит от версии компилятора и винды. Нех;№% заниматься временным и растрачивать жизнь на сиюминутное.

Люди, есть код:

Цитата:

var
rDB: DBDesc ;
begin
Check(DbiGetDatabaseDesc('DBFTBLS', @rDB)) ;
DDName := StrPas(rDB.szPhyName) + '\';
end;

Взято из форума по Delphi, вставлено в приложение на Д6 и нормально исполняется, - получаем путь к базе по алиасу 'DBFTBLS'.

Но это не работает, если код вставлен в FormCreate, - получаем ошибку $2104:



Не понимаю, - пожалуйста, расскажите, что за фича?

Добавлено:
Разобрался.
Надо:
Цитата:

var
rDB: DBDesc ;
begin
Session.Open;
Check(DbiGetDatabaseDesc('DBFTBLS', @rDB)) ;
DDName := StrPas(rDB.szPhyName) + '\';
end;

Спасибо всем!

[удалено]
Разобрался