位图分析程序 供大家参考 同时感谢帮助过我的人(0分)

unit Main;

interface

uses
SysUtils, Windows, Messages, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls, Buttons, ExtCtrls, Menus, ExtDlgs, Grids,
DBGrids, ShellApi, Jpeg;

type
TMainForm = class(TForm)
Panel1: TPanel;
MainMenu: TMainMenu;
N1: TMenuItem;
N2: TMenuItem;
N3: TMenuItem;
N4: TMenuItem;
N5: TMenuItem;
N6: TMenuItem;
N7: TMenuItem;
N8: TMenuItem;
N9: TMenuItem;
OpenPictureDialog: TOpenPictureDialog;
GroupBox1: TGroupBox;
GroupBox2: TGroupBox;
Image1: TImage;
BitSizeLabel: TLabel;
SizeShow: TEdit;
Label2: TLabel;
WidthShow: TEdit;
Label3: TLabel;
HeightShow: TEdit;
Label4: TLabel;
FaceShow: TEdit;
Label5: TLabel;
PixShow: TEdit;
Label6: TLabel;
ColorNum: TEdit;
Label8: TLabel;
Label9: TLabel;
Horizen: TEdit;
Veticle: TEdit;
Label10: TLabel;
YaSuo: TEdit;
Label11: TLabel;
NumSize: TEdit;
Label12: TLabel;
ImColor: TEdit;
GroupBox3: TGroupBox;
Label7: TLabel;
Label13: TLabel;
BmpJPEG1: TMenuItem;
N10: TMenuItem;
N11: TMenuItem;

procedure N2Click(Sender: TObject);
procedure N4Click(Sender: TObject);
procedure N9Click(Sender: TObject);
procedure N7Click(Sender: TObject);
procedure N8Click(Sender: TObject);
procedure N3Click(Sender: TObject);
procedure BmpJPEG1Click(Sender: TObject);
procedure N10Click(Sender: TObject);
procedure N11Click(Sender: TObject);

end;

var
MainForm: TMainForm;


implementation

uses Unit1;

{$r *.dfm}
function HexToDec( S : String ) : String;
var I : Integer;
begin
Result := '';
for I := 1 to ( Length( S ) div 2 ) do
begin
Result := Result + Format( '%3d',[StrToInt( '$' + Copy( S,2 * ( I - 1 ),2 ) )] );
end;
end;


function ToHex( S : String ) : String;
var I : Integer;
begin
Result := '';
for I := 1 to Length( S ) do
begin
Result := Result + IntToHex( Ord( S[ I ] ),0 );
end;
end;


Function ClearZero(Var Str:String):String;
var
i : integer;
begin
i := 1;
while(Str = '0') do
begin
if Str <> '0' then
break;
Str := ' ';
i := i + 1;
end;
Str := TrimLeft(Str);
Result := Str;
end;
procedure TMainForm.N2Click(Sender: TObject);
var

BitMap: file;
NumRead, TempInt : integer;
Buffer: array[0..2028] of byte;
StrTemp,Temp : String;
Temp1,Temp2,Temp3,Temp4:LongInt;
begin
OpenPictureDialog.Execute;
Temp1 := 0;
if(OpenPictureDialog.FileName = '') then
showMessage('请选择文件')
else
begin
Image1.Picture.LoadFromFile(OpenPIctureDialog.Filename);
AssignFile(BitMap,OpenPictureDialog.FileName);
reset(Bitmap, 1);
seek(BitMap, 0);
//bFileSize := Filesize(Bitmap);
BlockRead(BitMap, Buffer, SizeOf(Buffer), NumRead);
MainForm.SizeShow.Text :='';
Temp1 := Buffer[5] * 16 * 16 * 16 * 16 * 16 *16 * 16 * 16;
Temp2 := Buffer[4] * 16 * 16 * 16 *16;
Temp3 := Buffer[3] * 16 * 16;;
Temp4 := Buffer[2] * 1;
StrTemp := IntToStr(Temp1 + Temp2 + Temp3 + Temp4);
MainForm.SizeShow.Text:= StrTemp + ' 字 节 ';

//Width and Higth
Temp1 := Buffer[21] * 16 * 16 * 16 * 16 * 16 *16 * 16 * 16;
Temp2 := Buffer[20] * 16 * 16 * 16 *16;
Temp3 := Buffer[19] * 16 * 16;;
Temp4 := Buffer[18] * 1;
StrTemp := IntToStr(Temp1 + Temp2 + Temp3 + Temp4);
MainForm.WidthShow.Text:=StrTemp;
Temp1 := Buffer[23] * 16 * 16;
Temp2 := Buffer[22] * 1;
StrTemp := IntToStr(Temp1 + Temp2);
MainForm.HeightShow.Text := StrTemp;

//BitMap Bit Face
Temp3 := Buffer[25] * 16 * 16;;
Temp4 := Buffer[24] * 1;
StrTemp := IntToStr(Temp3 + Temp4);
MainForm.FaceShow.Text := StrTemp;

//
Temp1 := Buffer[27] * 16 * 16;
Temp2 := Buffer[26] * 1;
StrTemp := IntToStr(Temp1 + Temp2);
MainForm.PixShow.Text := StrTemp;

//ColorNum

Temp1 := Buffer[49] * 16 * 16 * 16 * 16 * 16 *16 * 16 * 16;
Temp2 := Buffer[48] * 16 * 16 * 16 *16;
Temp3 := Buffer[47] * 16 * 16;;
Temp4 := Buffer[46] * 1;
StrTemp := IntToStr(Temp1 + Temp2 + Temp3 + Temp4);
MainForm.ColorNum.Text := StrTemp;

//
Temp1 := Buffer[41] * 16 * 16 * 16 * 16 * 16 *16 * 16 * 16;
Temp2 := Buffer[40] * 16 * 16 * 16 *16;
Temp3 := Buffer[39] * 16 * 16;;
Temp4 := Buffer[38] * 1;
StrTemp := IntToStr(Temp1 + Temp2 + Temp3 + Temp4);
MainForm.Horizen.Text := StrTemp;
Temp1 := Buffer[45] * 16 * 16 * 16 * 16 * 16 *16 * 16 * 16;
Temp2 := Buffer[44] * 16 * 16 * 16 *16;
Temp3 := Buffer[43] * 16 * 16;;
Temp4 := Buffer[42] * 1;
StrTemp := IntToStr(Temp1 + Temp2 + Temp3 + Temp4);
MainForm.Veticle.Text := StrTEmp;

//压缩方法
Temp1 := Buffer[33] * 16 * 16 * 16 * 16 * 16 *16 * 16 * 16;
Temp2 := Buffer[32] * 16 * 16 * 16 *16;
Temp3 := Buffer[31] * 16 * 16;;
Temp4 := Buffer[30] * 1;
StrTemp := IntToStr(Temp1 + Temp2 + Temp3 + Temp4);
if StrTemp = '0' then StrTemp := '使用 BI_RGB';
if StrTemp = '1' then StrTemp := '使用 BI_RLE4';
if StrTemp = '2' then StrTemp := '使用 BI_RLE8';
if StrTemp = '3' then StrTemp := '使用 BI_BITFIELDS';
MainForm.YaSuo.Text := StrTemp;

//
Temp1 := Buffer[37] * 16 * 16 * 16 * 16 * 16 *16 * 16 * 16;
Temp2 := Buffer[36] * 16 * 16 * 16 *16;
Temp3 := Buffer[35] * 16 * 16;;
Temp4 := Buffer[34] * 1;
StrTemp := IntToStr(Temp1 + Temp2 + Temp3 + Temp4);
MainForm.NumSize.Text := StrTemp;

//
Temp1 := Buffer[53] * 16 * 16 * 16 * 16 * 16 *16 * 16 * 16;
Temp2 := Buffer[52] * 16 * 16 * 16 *16;
Temp3 := Buffer[51] * 16 * 16;;
Temp4 := Buffer[50] * 1;
StrTemp := IntToStr(Temp1 + Temp2 + Temp3 + Temp4);
MainForm.ImColor.Text := StrTemp;

CloseFile(BitMap);
end;


end;


procedure TMainForm.N4Click(Sender: TObject);
begin
MainForm.Close;
end;

procedure TMainForm.N9Click(Sender: TObject);
begin
ShellExecute(handle, 'open', Pchar('mailto:youremail@163.com'), nil, nil, SW_SHOWNORMAL);
end;

procedure TMainForm.N7Click(Sender: TObject);
begin
showMessage('本软件不需要任何帮助如果你真的需要请发邮件TopStation@msn.com');
end;

procedure TMainForm.N8Click(Sender: TObject);
begin
AboutOur.show;
end;

procedure TMainForm.N3Click(Sender: TObject);
begin
if(OpenPictureDialog.FileName = '') then
showMessage('没有需要保存数据')
else
showMessage('数据已经保存');
end;

procedure TMainForm.BmpJPEG1Click(Sender: TObject);
var
jp : TJpegImage;
begin
if OpenPictureDialog.FileName = '' then
showMessage('没有图象文件')
else
begin
jp := TJpegImage.Create;
try
with jp do
begin
Assign(Image1.Picture.Bitmap);
Image1.Picture.Assign(jp);
SaveToFile('d:/Tmp.jpg');
end;
finally
jp.free;
end;
end;
end;
procedure TMainForm.N10Click(Sender: TObject);


var
o_a : array of array of byte;
l_a : array of array of byte;
o_h : integer;
o_w : integer;
l_h : integer;
l_w : integer;

i, j, rgbValue:integer;
rvalue, gvalue, bvalue:byte;
grayValue:Extended;
pArr1, pArr2: PByteArray;
bmp : TBitMap;
begin
if OpenPictureDialog.FileName = '' then
ShowMessage('请打开文件')
else
begin
o_h := image1.Picture.Height;
o_w := Image1.Picture.Width;
l_h := o_h;
l_w := o_w;
setLength(o_a, o_h, o_w);
setLength(l_a, l_h, l_w);
if image1.Picture.Bitmap.Handle <> 0 then
begin
bmp := TBitmap.Create;
bmp.Assign(Image1.Picture.Bitmap);
try
for i:=0 to o_h - 1 do
begin
pArr1 := Image1.Picture.Bitmap.ScanLine;
pArr2 := bmp.ScanLine;
for j:= 0 to o_w - 1 do
begin
rgbValue := pArr1[j];
rvalue := getRvalue(rgbValue);
gvalue := getGvalue(rgbValue);
bvalue := getBvalue(rgbValue);

//
grayValue := 0.3 * rvalue + 0.59 * gvalue + 0.11 * bvalue;
grayValue := RGB(Byte(Trunc(grayValue)),Byte(Trunc(grayValue)),Byte(Trunc(grayValue)));
pArr2[j] := Trunc(grayValue);
end;
end;
Image1.Picture.Bitmap.Assign(bmp);
finally
bmp.free;
end;
end;
end;

end;

procedure TMainForm.N11Click(Sender: TObject);
var
DummyImage : TImage;
X, Y : integer;
SrcRect, DstRect : TRect;
begin
if OpenPictureDialog.FileName = '' then
showMessage('没有图象文件')
else
begin
//获取图片大小
X := Image1.Picture.Width;
Y := Image1.Picture.Height;
//创建临时文件
DummyImage := TImage.Create(Self);
try
//执行水平镜像翻转
SrcRect := Rect(0, 0, X, Y);
DstRect := Rect(X, Y, 0, 0);
DummyImage.Width := X;
DummyImage.Height := Y;
DummyImage.Canvas.CopyMode := cmSrcCopy;
DummyImage.Canvas.CopyRect(DstRect, Image1.Canvas, SrcRect);
Image1.Picture := DummyImage.Picture;
//SrcRect := Rect(0, 0, X, Y);
//SrcRect := Rect(0, Y, X, 0);
//DummyImage.Width := X;
//DummyImage.Heigth := Y;
//DummyImage.Canvas.CopyMode := cmSrcCopy;
//DummyImage.Canvas.CapyRect(DstRect, Image1.Canvas, SrcRect);
finally
DummyImage.Free;
end;
end;
end;
end.



//unit1 程序 :

unit Unit1;

interface

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

type
TAboutOur = class(TForm)
Panel1: TPanel;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
Label4: TLabel;
Label5: TLabel;
Image1: TImage;
Timer1: TTimer;
procedure Timer1Timer(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
AboutOur: TAboutOur;

implementation

{$R *.dfm}

procedure TAboutOur.Timer1Timer(Sender: TObject);
begin
AboutOur.Close;
end;

end.

感谢！

真的是好人啊

还没看完，先感谢

不客气！

真是怕了你了。
不能提供源码下载吗？

我没有服务器 ！