unit1.pas

DICOM文件的读写程序

Unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    OpenDialog1: TOpenDialog;
    Button1: TButton;
    Memo1: TMemo;
    Image: TImage;
    CheckBox1: TCheckBox;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
		Buff   : PChar;
	  width  : Integer;
	  height : Integer;
    { Public declarations }
		procedure DisplayImage;
  end;

(***********************************************************)
type
	int32  = LongInt;
	uint32 = Cardinal;
	int16  = SmallInt;
	uint16 = Word;
	int8   = ShortInt;
	uint8  = Byte;

function read16( var fp : File ): uint16;
function read32 ( var fp : File ): uint32;
procedure read_dicom_data( var buff : PChar; var width:Integer;
                           var height:Integer; var fp:File );
procedure flip_16bit_data ( var buff : PChar; width : Integer; height:Integer);
procedure scale16to8( var buff : PChar; width : Integer; height:Integer);


var
	little_endian   : Integer = 1;  //1 for pre-swapped
	bytes_per_pixel : Integer = 1;
	scale_flag      : Integer = 0;  //scale 16 bits to 8
	flip_flag       : Integer = 0;  //flip 16 bit data values
	no_flip_flag    : Integer = 0;  //no flip no matter what!
	invert_flag     : Integer = 0;	//invert data values

	infp  : File;  	//DICOM file
	textfp : Text;  //text file containing DICOM header info

var
  Form1: TForm1;

implementation

{$R *.DFM}

(***********************************************************)
procedure TForm1.Button1Click(Sender: TObject);
begin
  if OpenDialog1.Execute then
  begin
			// open the input DICOM file
		AssignFile(infp, OpenDialog1.FileName);
	  Reset(infp, 1);

			// open the DICOM text file
		AssignFile(textfp, 'text.txt');
	  Rewrite(textfp);

		read_dicom_data(buff, width, height, infp);

		if CheckBox1.Checked then
		begin
    	flip_flag := 1;
    	flip_16bit_data ( buff, width, height);
		end;

		scale16to8( buff, width, height );

    CloseFile(infp);
    CloseFile(textfp);

    Memo1.Lines.LoadFromFile('text.txt');

// Display Image
    DisplayImage;
  end;
end;


procedure TForm1.DisplayImage;
var
  I       : Integer;
	hBmp    : HBITMAP;
  BI      : PBitmapInfo;
  BIH     : TBitmapInfoHeader;
  Bmp     : TBitmap;
  TmpDC   : hDC;
  ImagoDC : hDC;
begin
		// Fill BitmapInfoHeader structure
	BIH.biSize   		 	 	:= Sizeof(BIH);
	BIH.biWidth  		 	 	:= width;
  BIH.biHeight 		 	 	:= -height;
	BIH.biPlanes 		 	 	:= 1;
  BIH.biBitCount 	 	 	:= 8;
	BIH.biCompression 	:= BI_RGB;
  BIH.biSizeImage	 	 	:= 0;
	BIH.biXPelsPerMeter := 0;
  BIH.biYPelsPerMeter := 0;
	BIH.biClrUsed       := 0;
  BIH.biClrImportant  := 0;

{$P+,S-,W-,R-}

 		// Create DIB Bitmap Info with actual color table
	BI := AllocMem(SizeOf(TBitmapInfoHeader) + 256*Sizeof(TRGBQuad));
	try
	  BI^.bmiHeader := BIH;
	  for I:=0 to 255 do begin
  		BI^.bmiColors[I].rgbBlue     := Byte( I );
    	BI^.bmiColors[I].rgbGreen    := Byte( I );
	    BI^.bmiColors[I].rgbRed      := Byte( I );
		  BI^.bmiColors[I].rgbReserved := 0;
    end;

	  Bmp        := TBitmap.Create;
  	Bmp.Height := width;
	  Bmp.Width  := height;

	  ImagoDC := GetDC(Form1.Handle);
	  hBmp :=  CreateDIBitmap(
    				ImagoDC,		// handle of device context
    				BIH,									// address of bitmap size and format data
    				CBM_INIT,							// initialization flag
	    			buff,									// address of initialization data
  	  			BI^,									// address of bitmap color-format data
    				DIB_RGB_COLORS ); 		// color-data usage
	  Bmp.Handle := hBmp;

			// Draw bitmap proportional into the given Image
//  	Image.Canvas.Brush.Color := clRED;
//	  Image.Canvas.FillRect(Image.BoundsRect);
//		Image.Canvas.StretchDraw(ImgRect, Bmp);
Image.Picture.Bitmap.Assign( Bmp );
Image.Refresh;

	  Bmp.Free;
	except
//		showmessage(MainForm.MultiLanguage1.GetMsg('XOutOfMemory'));
	  exit;
  end;
  FreeMem( BI, SizeOf(TBitmapInfoHeader) + 256*Sizeof(TRGBQuad));

{$P-,S+,W+,R+}
end;











(***********************************************************)
function read16( var fp : File ): uint16;
var
	t1, t2 : uint8;
  n      : Integer;
begin
	BlockRead(fp, t1, SizeOf(uint8), n);
	BlockRead(fp, t2, SizeOf(uint8), n);

  if little_endian <> 0
  	then Result := (t1 + t2*256) AND $FFFF
  	else Result := (t1*256 + t2) AND $FFFF;
end;

(***********************************************************)
function read32 ( var fp : File ): uint32;
var
	t1, t2, t3, t4 : uint8;
  n : Integer;
begin
	BlockRead(fp, t1, SizeOf(uint8), n);
	BlockRead(fp, t2, SizeOf(uint8), n);
	BlockRead(fp, t3, SizeOf(uint8), n);
	BlockRead(fp, t4, SizeOf(uint8), n);

  if little_endian <> 0
  	then Result := (t1 + t2*256 + t3*256*256 + t4*256*256*256) AND $FFFFFFFF
    else Result := (t1*256*256*256 + t2*256*256 + t3*256 + t4) AND $FFFFFFFF;
end;

(***********************************************************)
procedure read_dicom_data( var buff : PChar; var width:Integer;
                           var height:Integer; var fp:File );
type
  dicom_types = (unknown, i8, i16, i32, ui8, ui16, ui32, _string );
var
	first_one    : Boolean;
  time_to_quit : Boolean;

	group, element, dummy, e_len, remaining, tmp : uint32;
  info   : string;
  t      : dicom_types;
  where  : LongInt;
  tx     : array [0..3] of Char;
  n, i   : Integer;
begin
  info := '';
  t := unknown;

		// try DICOM part 10 i.e. a 128 byte file preamble followed by "DICM"
  seek(fp, 0);
	where := FilePos(fp);
	BlockRead(fp, tx, 4*SizeOf(Char), n);
  if (tx[0] <> 'D') OR (tx[1] <> 'I') OR (tx[2] <> 'C') OR (tx[3] <> 'M') then
	begin
	  seek(fp, 128); //skip the preamble - next 4 bytes should be 'DICM'
  	where := FilePos(fp);
		BlockRead(fp, tx, 4*SizeOf(Char), n);
		if (tx[0] <> 'D') OR (tx[1] <> 'I') OR (tx[2] <> 'C') OR (tx[3] <> 'M') then
		begin
//    	showmessage('not a proper DICOM file');

      	// try DICOM without header
	  	seek(fp, 0);
	   	group   := read16(fp);
	    element := read16(fp);
      if NOT (group in [$0000, $0002, $0004, $0008]) then
				exit;
	  	seek(fp, 0);
		end;
	end;

		// Read DICOM Tags
	time_to_quit := FALSE;
	while NOT time_to_quit do
  begin
  	where     := FilePos(fp);
   	group     := read16(fp);
    element   := read16(fp);
    if group = $0002 then
    begin
   		dummy := read16(fp);
   		e_len := read16(fp);
      if element = $0001 then
      begin
   			dummy := read32(fp);
   			dummy := read16(fp);
        e_len := 0;
      end;
    end
    else e_len := read32(fp);
	  remaining := e_len;

		info := 'unknown';
    case group of
    	$0002 :
      	case element of
        	$00 :  info := 'file meta elements group len';
          $01 :  info := 'file meta info version';
          $02 :  info := 'media storage SOP class uid';
          $03 :  info := 'media storage SOP inst uid';
          $10 :  info := 'transfer syntax uid';
          $12 :  info := 'implementation class uid';
          $13 :  info := 'implementation version name';
          $16 :  info := 'source app entity title';
          $100:  info := 'private info creator uid';
          $102:  info := 'private info';
				end;
      $0008 :
        case element of
          $00 :  info := 'identifying group';
          $01 :  info := 'length to end';
          $08 :  info := 'image type';
          $10 :  info := 'recognition code';
          $16 :  info := 'SOP Class UID';
          $18 :  info := 'SOP Instance UID';
          $20 :  info := 'study date';
          $21 :  info := 'series date';
          $22 :  info := 'acquisition date';
          $23 :  info := 'image date';
          $30 :  info := 'study time';
          $31 :  info := 'series time';
          $32 :  info := 'acquisition time';
          $33 :  info := 'image time';
          $40 :  info := 'data set type';
          $41 :  info := 'data set subtype';
          $50 :  info := 'accession number';
          $60 :  begin info := 'modality';  t := _string; end;
          $70 :  info := 'manufacturer';
          $80 :  info := 'institution name';
          $90 :  info := 'referring physician''s name';
          $1010: info := 'station name';
          $103e: info := 'series description';
          $1030: info := 'study description';
          $1040: info := 'institutional dept. name';
          $1060: info := 'name phys(s) read stdy';
          $1070: begin info := 'operator''s name';  t := _string; end;