求高效的多线程代码!谢谢 ( 积分: 100 )

type
TSWFInfo = record
xMin: integer;
//
xMax: integer;
//
yMin: integer;
//
yMax: integer;
//
FrameCount: integer;
end;

procedure WriteTxtInfo(sFileName, txtInfo: string);
var
m_Info: string;
FileResult: THandle;
TmpTxtFile: TextFile;
begin
try
if not FileExists(sFileName) then
begin
FileResult := FileCreate(sFileName);
FileClose(FileResult);
AssignFile(TmpTxtFile, sFileName);
ReWrite(TmpTxtFile);
CloseFile(TmpTxtFile);
end;

m_Info := txtInfo + #13#10;
FileResult := FileOpen(sFileName, fmOpenReadWrite or fmShareDenyNone);
if FileResult > 0 then
begin
FileSeek(FileResult, 0, 2);
FileWrite(FileResult, m_Info[1], Length(m_Info));
FileClose(FileResult);
end;
except
on e: exceptiondo
begin
//MessageBox(Handle, pChar('txtWriteInfo 处出错！详情' + #13#10 + E.Message), '', mb_Ok + mb_IconInformation);
Exit;
end;
end;
end;

procedure GetColor;
var
tmpFrame, tmpX, tmpY: integer;
tmpString: string;
C: Cardinal;
FilePath: string;
FrameMin, FrameMax: integer;
xMin, xMax, yMin, yMax: integer;
SWFInfo: TSWFInfo;
begin
Screen.Cursor := crHourGlass;
try
FilePath := 'd:/123.txt';
// 取得SWF文件头信息
// SWFRect...
// ...
xMin := SWFInfo.xMin; // 值范围在0~1000
xMax := SWFInfo.xMax; // 值范围在0~1000
yMin := SWFInfo.yMin; // 值范围在0~1000
yMax := SWFInfo.yMax; // 值范围在0~1000
FrameMin := 1;
FrameMax := SWFInfo.FrameCount; // 值范围在1~3500左右
for tmpFrame := FrameMin to FrameMaxdo
begin
frmFlash.ShockwaveFlash1.StopPlay();
frmFlash.ShockwaveFlash1.GotoFrame(tmpFrame);
frmFlash.Update;
tmpString := '第 [' + IntToSTr(tmpInteger) + '] 帧';
WriteTxtInfo(FilePath, tmpString);
for tmpX := xMin to xMaxdo
begin
tmpString := '';
for tmpY := yMin to yMaxdo
begin
C := GetPixel(GetDc(frmFlash.ShockwaveFlash1.Handle), tmpX, tmpY);
TmpString := TmpString + '(X: ' + IntToStr(tmpX)
+ ', Y: ' + IntToStr(tmpY) + '): $'
+ IntToHex(GetRValue(C), 2)
+ IntToHex(GetGValue(C), 2)
+ IntToHex(GetBValue(C), 2);
end;

WriteTxtInfo(FilePath, tmpString);// 将该点颜色写入到文本文件中
end;
end;
except
showmessage('');
end;
Screen.Cursor := crDefault;
end;

procedure TfrmMain.BitBtn1Click(Sender: TObject);
var
// m_Thread: TThreadFindFrame;
hGetColorThread: THandle;
ThID: dWord;
begin

try
hGetColorThread := begin
Thread(nil, 0,
@GetColor, nil, 0, ThID);
if hGetColorThread = 0 then
messageBox(Handle, '线程失败，5555~~~', '', mb_Ok + mb_IconInformation)
except
on e: exceptiondo
begin
messageBox(handle, pChar(E.Message), '', mb_Ok + mb_IconInformation);
Exit;
end;
end;

end;

说明：上面代码的功能是在指定SWF动画中，取每一帧里指定坐标点的颜色!!
由于一些动画中帧相对较多，或者每帧当中取的坐标较多!所以程序效率比较低!
所以，特求一段高效代码!谢谢

正无聊，帮你写段，自己再试试
代码下面。。。改之

TO:QQ在线
谢谢，我在用你代码在对一个 200 X 200，20帧的动画取色时!第一帧没取完，程序就出错了!而且程序进入假死状态
好像还是没有解决问题!
继续等

procedure GetColor;
var
TxtHandle: THandle;
TxtBuffer: PChar;
TxtBufVal, TxtBufSize: Integer;
procedure InitTxt(const AFileName: string);
begin
TxtHandle := CreateFile(PChar(AFileName), GENERIC_WRITE, 0, nil, CREATE_ALWAYS,
FILE_ATTRIBUTE_NORMAL, 0);
TxtBufSize := 102400 * 5;
TxtBuffer := AllocMem(TxtBufSize);
TxtBufVal := 0;
end;

procedure WriteTxtInfo(const AMsg: string);
overload;
var
L: Integer;
begin
L := Length(AMsg);
if L + TxtBufVal > TxtBufSize then
begin
FileWrite(TxtHandle, TxtBuffer^, TxtBufVal);
TxtBufVal := 0;
end;
Move(PChar(AMsg)^, (TxtBuffer + TxtBufVal)^, L);
Inc(TxtBufVal, L);
end;

procedure WriteTxtInfo(X, Y: Integer;
Color: TColor);
overload;
const
SLineFormat = '(X: %d, Y: %d): $%.6X'#13#10;
var
L: Integer;
Buf: array [0..200] of Char;
begin
L := FormatBuf(Buf[0], MaxInt, PChar(SLineFormat)^, Length(SLineFormat), [X, Y, Integer(Color)]);
if L + TxtBufVal > TxtBufSize then
begin
FileWrite(TxtHandle, TxtBuffer^, TxtBufVal);
TxtBufVal := 0;
end;
Move(Buf[0], (TxtBuffer + TxtBufVal)^, L);
Inc(TxtBufVal, L);
end;

procedure FreeTxt;
begin
if TxtBufVal > 0 then
FileWrite(TxtHandle, TxtBuffer^, TxtBufVal);
FreeMem(TxtBuffer);
CloseHandle(TxtHandle);
end;

var
tmpFrame, tmpX, tmpY: integer;
tmpString: string;
C: Cardinal;
FilePath: string;
FrameMin, FrameMax: integer;
xMin, xMax, yMin, yMax: integer;
SWFInfo: TSWFInfo;
begin
Screen.Cursor := crHourGlass;
FilePath := 'd:/123.swf';
InitTxt(FilePath);
try
try
// 取得SWF文件头信息
// SWFRect...
// ...
xMin := SWFInfo.xMin;
// 值范围在0~1000
xMax := SWFInfo.xMax;
// 值范围在0~1000
yMin := SWFInfo.yMin;
// 值范围在0~1000
yMax := SWFInfo.yMax;
// 值范围在0~1000
FrameMin := 1;
FrameMax := SWFInfo.FrameCount;
// 值范围在1~3500左右
FrameMax := 10;
xMin := 0;
xMax := 10;
yMin := 0;
yMax := 100;
for tmpFrame := FrameMin to FrameMaxdo
begin
//frmFlash.ShockwaveFlash1.StopPlay();
//frmFlash.ShockwaveFlash1.GotoFrame(tmpFrame);
//frmFlash.Update;
//tmpString := '第 [' + IntToSTr(tmpInteger) + '] 帧';
tmpString := '第 [' + IntToSTr(tmpFrame) + '] 帧';
WriteTxtInfo(tmpString);
for tmpX := xMin to xMaxdo
begin
tmpString := '';
for tmpY := yMin to yMaxdo
begin
//C := GetPixel(GetDc(frmFlash.ShockwaveFlash1.Handle), tmpX, tmpY);
C := TColor($010203);
WriteTxtInfo(tmpX, tmpY, C);
end;
WriteTxtInfo(sLineBreak);// 换行符
end;
end;
except
showmessage('');
end;
finally
FreeTxt;
Screen.Cursor := crDefault;
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
GetColor
end;

我用上面代码测试，正常啊。你再检查下看看

谢谢，代码是正常可以用的!
但是感觉还是很卡!!!

因为你最终要写文件，没法
不然将TxtBufSize := 100M
全部先写到内存，再写入到文件，不过估计没什么太大改进。
频繁写文件效率是低的。
不清楚怎么调试的，继续看楼下有何解吧。

谢谢你!
我觉得把读色和写色分别放入不到的线程中应该会好一点!
只是还没找到一个完善的解决方法!
只好继续等了!

唉...

?????
呵呵。。。唉什么呢？

顶起来。。。
继续期待，谢谢

GETCOLOR可能比较占CPU，你先测试一下，

//C := GetPixel(GetDc(frmFlash.ShockwaveFlash1.Handle), tmpX, tmpY);
C := TColor($FFFFFF);
WriteTxtInfo(tmpX, tmpY, C);
测试结果：
画布大小 200 X 200
20帧
生成的TXT文件近20M，耗时3S不到一点！
请问还有别的取色方法吗？
谢谢

你先测试一下，哪个函数各占用多少时间~~
这样就可以知道哪儿需要优化了。

比较费时间的就是
GetPixel(...);
这里
用上面的动画 20帧，200X200，用GetPixel取色，基本上第一帧取不完程序就快完了！
而我直接用同一个值写文件时，生成的TXT文件近20M，耗时3S不到一点！
呵呵。。。所以我估计是取色的时候太耗资源了！
谢谢

我唉的意思是你的程序太过僵化, 或者你对电脑、数据、程序、读写等...都很陌生.
1. 最重要的一点就是你对一个本来是连续事务的数据保存竟然使用无数次的文件打开、寻址、写数据、关闭..., 本来只要打开一次,不用寻址,连续写到结尾的;
2. 其实使用可视文本保存数据是最差的一种数据保存方法, IO速度慢, 中间还要很多转化(数据-->文本的转换,还有文本串的+操作等都是效率很底的);
3. 如果一定要求速度, 你可以使用不可视的数据(原始的、直接的二进制数据)保存数据,例如获取的颜色点是个16位的整数, 就直接保存这个16位(两个字节)的整数,效率高很多;
4. 当然最后你在应用这个结果数据文件的时候,也按照二进制数据操作就是了;
5. 我唉的意思是你的思维方式或者你目前对数据处理的了解不合适写程序.
6. 加油吧!

TO：新世纪
首先，谢谢你的回复！也谢谢你给我提出了这么多可以尝试的线索！
我明白，我的程序本身有着很大的问题，所以我才来找一种高效的解决，写程序本身也是一个学习的过程，没有人生来是什么都会的！
也许你是位高人，也许你看着这么一段差劲的代码直摇头，感叹怎么会把这点东西写成这样！虽然代码本身不怎么像样，但这也是我努力的结果，虽然不怎么完美，但我会尽力修改它。
再次感谢您的批评和建议！

建议：
1.用全局文件变量，打开一次，Write若干次，最后关闭一次即可——这样可以极大的提高
磁盘IO效率。
2.不要使用GetPixel这样的针对点的函数——效率太低了。应该参考1474153号帖子，使用
GetDC以及位图的ScanLine数组属性。另外，538683号帖子也做了很深入的探讨。

ScanLine 在有些机上也慢

to: creation-zy
谢谢！
1、程序已经改为这种实现方式了！
2、我去研究一下！