Нашли или выдавили из себя код, который нельзя назвать нормальным, на который без улыбки не взглянешь? Не торопитесь его удалять или рефакторить, — запостите его на говнокод.ру, посмеёмся вместе!
+76
procedure TForm1.FormCreate(Sender: TObject);
begin
SetCurrentDir(ExtractFileDir(Application.ExeName));
try
ADOConnection1.Connected:=true;
if ADOConnection1.Connected=true then
begin
ADOTable1.Active:=True;
end;
except
MessageDLG('Îøèáêà ïîäêëþ÷åíèÿ ÁÄ',mtError,[mbOk],0);
end;
SetCurrentDir(ExtractFileDir(Application .ExeName));
Не знаю, откуда ты, но знаю, куда тебе дальше.
Stertor,
03 Декабря 2013
+133
function tform1.ExistsFiles(path:string):boolean;
var
hfile:thandle;
fname:string;
WD:win32_find_dataA;
begin
result:=false;
if directoryexists(path)=false then
exit;
path:=includetrailingpathdelimiter(path);
hfile:=FindFirstFile(pchar(path+'*.*'),wd);
if hfile <> invalid_handle_value then
begin
repeat
fname:=string(wd.cFileName);
if (fname <> '.') and (fname <> '..') then
begin
if (wd.dwFileAttributes and file_attribute_directory <> 0) then
begin
if existsfiles(path+fname)=true then
begin
result:=true;
break;
end;
end
else
if ansilowercase(extractfileext(fname))='.txt' then
begin
result:=true;
break;
end;
end;
until findnextfile(hfile,wd) <> true;
windows.findclose(hfile);
end;
end;Проверяем, есть ли в папке и ее подпапках текстовые документы...
Stertor,
26 Ноября 2013
+132
procedure tnewthread.checkfiles; // процедура выполняется в потоке
var
i:integer;
status:tstatus;
ptmp:array of char;
temp:string;
len:integer;
fstream:tfilestream;
begin
flist.Clear;
findfiles(findpath);
for i:=flist.Count-1 downto 0 do
begin
status:=s_ok;
try
try
fstream:=tfilestream.Create(flist[i],fmopenread);
fstream.Position:=0;
setlength(ptmp,fstream.size);
fstream.Read(pointer(ptmp)^,fstream.size);
except
status:=s_error;
end;
finally
fstream.free;
end;
temp:=string(pchar(ptmp));
temp:=stringreplace(temp,' ',' ',[rfreplaceall]);
temp:=stringreplace(temp,'>','>',[rfreplaceall]);
temp:=stringreplace(temp,' ',' ',[rfreplaceall]);
temp:=stringreplace(temp,'<','<',[rfreplaceall]);
temp:=stringreplace(temp,'&','&',[rfreplaceall]);
temp:=stringreplace(temp,'"','"',[rfreplaceall]);
temp:=stringreplace(temp,'©',#169,[rfreplaceall]);
temp:=stringreplace(temp,#10,#13#10,[rfreplaceall]);
Len := Length(temp);
try
try
fstream:=tfilestream.Create('C:\1.txt',fmcreate); // заменил в целях теста, не помогает.
fstream.Position:=0;
fstream.WriteBuffer(temp[1], Len); // в этом месте поток вылетает с ошибкой "Range check error"
except
status:=s_error;
end;
finally
fstream.free;
end;
if status=s_ok then
begin
addfileinfo(flist[i]);
shrecyclefile(flist[i]);
end
else
begin
adderrinfo(flist[i]); // синхронизируемся с мемо и добавляем в него красную строчку с именем файла
shmovefile(flist[i],erroroutputpath +'\' + extractfilename(flist[i])); // перемещаем файл в директорию с файлами, при обр. которых произошла ошибка
end;
end;
end;
Процедура для обработки текстовых файлов. Имеем дремлющий поток, залоченный waitsingleobject, который будит
таймерная функция, если в папке есть по крайней мере 1 файл. т.е. одновременно к файлам обращается 1 поток.
При разлочивании поток немедленно начинает заполнять лист именами файлов, после чего начинает прогонять их
через процедуру-обработчик. Но вот беда - возникает ошибка range check error. причем возникает только в доп.потоке -
вне потока все работает нормально. Товарищи ,не подскажете, в чем лажа? (
Stertor,
24 Ноября 2013
+138
// прога у нас многопоточная, данный код выполняется в потоке. Создание и настройка Idhttp прописана в конструкторе потока.
while not terminated do
begin
synchronize(ReadProxy);
if ThreadExit then break;
try
memorystream.Position:=0;
try
idHTTP.Get(linknew,memorystream);
idhttp.disconnect;
except
idhttp.Disconnect;
end;
finally
temp:=memorystreamtostring(memorystream); // если этого не сделать, память будет утекать.
memorystream.clear;
end;
Я нашел способ предотвратить утечки памяти в Indy, при Get-запросе -
многие грешат на Indy, мол, нестабильная она в потоках, провоцирует утечки.
Оказалось, что дело-то в tmemorystream, я его маму бля ебал!!!
Stertor,
19 Ноября 2013
+106
for i:= 1 to 24 do read (a[i]);
if (abs(sqrt ((a[1]-a[4])*(a[1]-a[4])+(a[2]-a[5])*(a[2]-a[5])+(a[3]-a[6])*(a[3]-a[6]))) = abs(sqrt ((a[4]-a[7])*(a[4]-a[7])+(a[5]-a[8])*(a[5]-a[8])+(a[6]-a[9])*(a[6]-a[9]))) and
(abs(sqrt ((a[4]-a[7])*(a[4]-a[7])+(a[5]-a[8])*(a[5]-a[8])+(a[6]-a[9])*(a[6]-a[9]))) =abs(sqrt ((a[7]-a[10])*(a[7]-a[10])+(a[8]-a[11])*(a[8]-a[11])+(a[9]-a[12])*(a[9]-a[12]))) and
(abs(sqrt ((a[7]-a[10])*(a[7]-a[10])+(a[8]-a[11])*(a[8]-a[11])+(a[9]-a[12])*(a[9]-a[12]))) =abs(sqrt ((a[10]-a[1])*(a[10]-a[1])+(a[11]-a[2])*(a[11]-a[2])+(a[12]-a[3])*(a[12]-a[3])))and
(abs(sqrt ((a[13]-a[16])*(a[13]-a[16])+(a[14]-a[17])*(a[14]-a[17])+(a[15]-a[18])*(a[15]-a[18]))) = abs(sqrt ((a[13]-a[16])*(a[13]-a[16])+(a[14]-a[17])*(a[14]-a[17])+(a[15]-a[18])*(a[15]-a[18]))) and
(abs(sqrt ((a[13]-a[16])*(a[13]-a[16])+(a[14]-a[17])*(a[14]-a[17])+(a[15]-a[18])*(a[15]-a[18]))) =abs(sqrt ((a[16]-a[19])*(a[16]-a[19])+(a[17]-a[20])*(a[17]-a[20])+(a[18]-a[21])*(a[18]-a[21]))) and
(abs(sqrt ((a[16]-a[19])*(a[16]-a[19])+(a[17]-a[20])*(a[17]-a[20])+(a[18]-a[21])*(a[18]-a[21]))) =abs (sqrt ((a[19]-a[22])*(a[19]-a[22])+(a[20]-a[23])*(a[20]-a[23])+(a[21]-a[24])*(a[21]-a[24]))) and
(abs(sqrt ((a[19]-a[22])*(a[19]-a[22])+(a[20]-a[23])*(a[20]-a[23])+(a[21]-a[24])*(a[21]-a[24]))) =abs(sqrt ((a[22]-a[13])*(a[22]-a[13])+(a[23]-a[14])*(a[23]-a[14])+(a[24]-a[15])*(a[24]-a[15]))) and
(abs(sqrt ((a[22]-a[13])*(a[22]-a[13])+(a[23]-a[14])*(a[23]-a[14])+(a[24]-a[15])*(a[24]-a[15])))=abs(sqrt ((a[13]-a[1])*(a[13]-a[1])+(a[14]-a[2])*(a[14]-a[2])+(a[15]-a[3])*(a[15]-a[3]))) and
(abs(sqrt ((a[13]-a[1])*(a[13]-a[1])+(a[14]-a[2])*(a[14]-a[2])+(a[15]-a[3])*(a[15]-a[3]))) = abs(sqrt ((a[16]-a[4])*(a[16]-a[4])+(a[17]-a[5])*(a[17]-a[5])+(a[18]-a[6])*(a[18]-a[6])))and
(abs(sqrt ((a[16]-a[4])*(a[16]-a[4])+(a[17]-a[5])*(a[17]-a[5])+(a[18]-a[6])*(a[18]-a[6])))= abs(sqrt ((a[19]-a[1])*(a[19]-a[7])+(a[20]-a[8])*(a[20]-a[8])+(a[21]-a[9])*(a[21]-a[9]))) and
(abs(sqrt ((a[19]-a[1])*(a[19]-a[7])+(a[20]-a[8])*(a[20]-a[8])+(a[21]-a[9])*(a[21]-a[9]))) = abs(sqrt ((a[22]-a[10])*(a[22]-a[10])+(a[23]-a[11])*(a[23]-a[11])+(a[24]-a[12])*(a[24]-a[12])))) then writeln ('yes');
Readln;программа выясняет, является ли фигура с задаными 24 координатами кубом
Abbath,
20 Октября 2013
+140
Товарищи, подскажите, как прикрутить скриптовый движок к парсеру на Delphi (а заодно и сам движок)!
Извращение это нужно, чтобы распарсить сайт, использующий скрипты.
webbrowser не подходит - слишком тормозно и глючно.
Stertor,
16 Октября 2013
+137
Товарищи, я прошу всех посмотреть вот этот фильм:
[запрос "Расскажите сказку, доктор!" на Яндекс]
Возможно, это выглядит нелепо - постить ссылку сюда, но все же, сделайте это.
Этот фильм был снят через несколько дней после войны.
На мой взгляд, имеет огромную воспитательную ценность.
Stertor,
21 Сентября 2013
+130
Program KrestZero;
...
procedure TForm1.DrawGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
Rect: TRect; State: TGridDrawState);
begin
case m[arow,acol]of
1: DrawGrid1.Canvas.Draw(acol*81,arow*81 ,bmpkrest);
0: DrawGrid1.Canvas.Draw(acol*81,arow*81 ,bmpfon);
2: DrawGrid1.Canvas.Draw(acol*81,arow*81 ,bmpnul);
end;
end;
function win:boolean;
var a:byte;
begin
result:=false;
k:=0;
for I := 0 to 2 do
if m[0,i]=a then k:=k+1;
if k=3 then begin result:=true; exit; end;
end;
procedure TForm1.DrawGrid1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var
acol,arow:integer;
begin
DrawGrid1.MouseToCell(x,y,acol,arow);
if (m[arow,acol]<>0) then
ShowMessage('Нельзя!')
else
begin
inc(hod);
if hod mod 2 =1 then m[arow,acol]:=1
else m[arow,acol]:=2;
if win then ShowMessage('Победа!');
end;
end;
procedure TForm1.FormShow(Sender: TObject);
var i,j:byte;
begin
bmpkrest:=TBitmap.Create;
bmpkrest.LoadFromFile('krest.bmp');
bmpfon:=TBitmap.Create;
bmpfon.LoadFromFile('fon.bmp');
bmpnul:=TBitmap.Create;
bmpnul.LoadFromFile('nol.bmp');
for i:=0 to 2 do
for j:=0 to 2 do
m[i,j]:=0;
hod:=0;
end;
А вот так, товарищи, кодит препод в одной из шаражек в нашем родном Владикавказе.
В коде ничего не менял - выложил, как есть.
Одно только название - krestzero уже поднимает давление настроение.
Stertor,
15 Сентября 2013
+139
type
TCriricalThread = class (TThread)
private
FileS : integer;
Percent : integer;
DlSize : integer;
procedure SetMaxPos;
procedure SetCurPos;
procedure LockButton;
procedure DislockButton;
protected
Ну, уж если есть критические секции, почему бы не сделать критический поток?
TCriricalThread = class (TThread)
Stertor,
11 Сентября 2013
+80
Главная » Усыпление программы
Усыпление программы
Автор: -Гепард97-
Написать автору
[просмотров 751]
В VBS есть функция wscript.sleep, позволяющая усыпить скрипт. Но как такое сделать в VB? Ответ прост: делаем новый модуль и пишем код:
Public Declare Sub Sleep Lib "kernel32" (byval dwMilliseconds As Long)
И все. Когда прогу нужно усыпить, просто пишем в коде проги, если например прога должна остановиться на 2 секунды то пишем
Sleep 2000
Этого способа нет на MSDN, я его сам отрыл
Билл Гатэс прочел это и уснул...
Z-z-z-z...
Stertor,
10 Сентября 2013
Follow us!