childwin.pas

用Delphi做的读取医学图片的控件及代码

if BackupBitmap = nil then exit;
  xActual := round((X *image.Picture.Height)/image.Height);
  yActual := round((Y *image.Picture.Width)/image.Width);


if (xActual < 0) or (yActual < 0) or (xActual > Image.Picture.width)
or (yActual > Image.Picture.height) then
   exit;
if (not gSmooth) and (gZoomPct <> 0) then
AreaRadius := (50 * 100) div gZoomPct
else
    AreaRadius := 50;
Magnification := {round((30*2) / (100))}AreaRadius*2;//round(( (( gZoomPct div 50)+1) * 100)  /gZoomPct * AreaRadius);
if (gMagRect.Left <> gMagRect.Right) then begin
   Image.Picture.Bitmap.Canvas.CopyRect(gMagRect,
                              BackupBitmap.Canvas, // [anme]
                              gMagRect);
end;
gMagRect := Rect(xActual - Magnification,
                                   yActual - Magnification,
                                   xActual + Magnification,
                                   yActual + Magnification);
Image.Picture.Bitmap.Canvas.CopyRect(gMagRect,
                              BackupBitmap.Canvas, // [anme]
                                Rect(xActual - AreaRadius,
                                   yActual - AreaRadius,
                                   xActual + AreaRadius,
                                   yActual + AreaRadius) );
  Image.refresh;
END; {ShowMagnifier}

procedure FireLUT (lIntensity, lTotal: integer; var lR,lG,lB: integer);
//Generates a 'hot metal' style color lookup table
var l255scale: integer;
begin
     l255Scale := round ( lIntensity/lTotal * 255);
     lR := (l255Scale - 52) * 3;
     if lR < 0 then lR := 0
     else if lR > 255 then lR := 255;
     lG := (l255Scale - 108) * 2;
     if lG < 0 then lG := 0
     else if lG > 255 then lG := 255;
     case l255Scale of
          0..55: lB :=  (l255Scale * 4);
          56..118: lB := 220-((l255Scale-55)*3);
          119..235: lB := 0;
          else lB := ((l255Scale-235)*10);
     end; {case}
     if lB < 0 then lB := 0
     else if lB > 255 then lB := 255;
end;


procedure TMDIChild.LoadColorScheme(lStr: string; lScheme: integer);
//Loads a color lookup tabel from disk.
//Lookup tables can either be in Osiris format (TEXT) or ImageJ format (BINARY: 768 bytes)
const UNIXeoln = chr(10);
var
   lF: textfile;
   lBuff: bytep0;
   lFdata: file;
   lCh: char;
   lNumStr: String;
   lRi,lGi,lBi,lZ: integer;
   lByte,lIndex,lRed,lBlue,lGreen: byte;
   lType,lIndx,lLong,lR,lG,lB: boolean;
procedure ResetBools;
begin
    lType := false;
    lIndx := false;
    lR := false;
    lG := false;
    lB := false;
    lNumStr := '';
end;
begin
     gScheme := lScheme;
     if lScheme < 3 then begin //AUTOGENERATE LUT 0/1/2 are internally generated: do not read from disk
        case lScheme of
           0: for lZ:=0 to 255 do begin //1: low intensity=white, high intensity = black
              gRra[lZ] := 255-lZ;
              gGra[lZ] := 255-lZ;
              gBra[lZ] := 255-lZ;
             end;
            2:  for lZ:=0 to 255 do begin //Hot metal LUT
                FireLUT (lZ,255,lRi,lGi,lBi);
                gRra[lZ] :=  lRi;
                gGra[lZ] := lGi;
                gBra[lZ]      := lBi ;
             end;
           else for lZ:=0 to 255 do begin //1: low intensity=black, high intensity = white
                gRra[lZ] := lZ;
                gGra[lZ] := lZ;
                gBra[lZ] := lZ;

             end;
        end; //case
        gMaxRGB := (gRra[255] + (gGra[255] shl 8)+(gBra[255] shl 16));
        gMinRGB := (gRra[0] + (gGra[0] shl 8)+(gBra[0] shl 16));
        exit;
     end; //AUTOGENERATE LUT
     lIndex := 0;
     lRed := 0;
     lGreen := 0;
     if gCustomPalette > 0 then exit;
     if not fileexists(lStr) then exit;
     assignfile(lFdata,lStr);
     filemode := 0;
     reset(lFdata,1);
     lZ := FileSize(lFData);
     if (lZ =768) or (lZ = 800) or (lZ = 970) then begin
        GetMem( lBuff, 768);
        Seek(lFData,lZ-768);
        BlockRead(lFdata, lBuff^, 768);
        closeFile(lFdata);
        for lZ := 0 to 255 do begin
            //lZ := (lIndex);
            gRra[lZ] := lBuff[lZ];
            gGra[lZ] := lBuff[lZ+256];
            gBra[lZ] := lBuff[lZ+512];
        end;

        {write output ->  
     filemode := 1;
     lZ := 256;
     AssignFile(lFData, 'C:\Documents and Settings\Chris\My Documents\imagen\smash.lut');
     Rewrite(lFData,1);
     BlockWrite(lFdata, lBuff[0], lZ);   //red
     BlockWrite(lFdata, lBuff[2*lZ], lZ); //blue
     BlockWrite(lFdata, lBuff[lZ], lZ); //green
     //BlockWrite(lFdata, lBuff^, lZ);
     CloseFile(lFData);

        {end write output}

        freemem(lBuff);
        gMaxRGB := (gRra[255] + (gGra[255] shl 8)+(gBra[255] shl 16));
        gMinRGB := (gRra[0] + (gGra[0] shl 8)+(gBra[0] shl 16));

        exit;

     end;
     closefile(lFdata);
     lLong := false;
     assignfile(lF,lStr);
     filemode := 0;
     reset(lF);
     ResetBools;
     for lByte := 0 to 255 do begin
         gRra[lByte] := 0;
         gGra[lByte] := 0;
         gBra[lByte] := 0;
     end;

(*Start PaintShopProConverter
        lNumStr := '';
        lCh := ' ';
            while (not EOF(lF)) and (lCh <> kCR) and (lCh <> UNIXeoln) do begin
                  read(lF,lCh); //header signatur JASC-PAL
                  lNumStr := lNumStr + lCh;
            end;
        lCh := ' ';
            while (not EOF(lF)) and (lCh <> kCR) and (lCh <> UNIXeoln) do begin
                  read(lF,lCh); //jasc header version 0100
                  lNumStr := lNumStr + lCh;
            end;
        lCh := ' ';
            while (not EOF(lF)) and (lCh <> kCR) and (lCh <> UNIXeoln) do begin
                  read(lF,lCh); //jasc header index items, e.g. 256
                  lNumStr := lNumStr + lCh;
            end;
//            showmessage(lNumStr);
            for lIndex := 0 to 255 do begin
              for lZ := 1 to 3 do begin
                lNumStr := '';
                repeat
                      read(lF,lCh);
                      if lCh in ['0'..'9'] then
                         lNumStr := lNumStr + lCh;
                until (lNumStr <> '') and (not (lCh in ['0'..'9']));
                case lZ of
                   1: gGra[lIndex] := strtoint(lNumStr);
                   2: grra[lIndex] := strtoint(lNumStr);
                   else gBra[lIndex] := strtoint(lNumStr);

                end; //case lZ
              end; //for lZ r,g,b loops

            end; //for lIndex 0..255 loops
            lIndex := 0;
     filemode := 1;
     lZ := 256;
     AssignFile(lFData, 'C:\Documents and Settings\Chris\My Documents\imagen\newlut.lut');
     Rewrite(lFData,1);
     BlockWrite(lFdata, gRra[1], lZ);   //red
     BlockWrite(lFdata, gGra[1], lZ); //blue
     BlockWrite(lFdata, gBra[1], lZ); //green
     //BlockWrite(lFdata, lBuff^, lZ);
     CloseFile(lFData);
     exit;
 (*end - PaintShopPro format*)

(* begin Osiris format reader *)

     //if EOF(lF) then
       //do not start reading
     //else repeat
     while not EOF(lF) do begin
         read(lF,lCh);
         if lCh = '*' then //comment character
            while (not EOF(lF)) and (lCh <> kCR) and (lCh <> UNIXeoln) do
                  read(lF,lCh);
         if (lCh = 'L') or (lCh = 'l') then begin
            lType := true;
            lLong := true;
         end; //'l'
         if (lCh = 's') or (lCh = 'S') then begin
            lType := true;
            lLong := false;
         end; //'s'
         if lCh in ['0'..'9'] then
             lNumStr := lNumStr + lCh;
         //note on next line: revised 9/9/2003: will read final line of text even if EOF instead of EOLN for final index
         if ((not(lCh in ['0'..'9'])) or (EOF(lF)) ) and (length(lNumStr) > 0) then begin //not a number = space??? try to read number string
              if not lIndx then begin
                 lIndex := strtoint(lNumStr);
                 lIndx := true;
              end else begin //not index
                  if lLong then
                     lByte := trunc(strtoint(lNumStr) / 256)
                  else
                      lByte := strtoint(lNumStr);
                  if not lR then begin
                     lRed := lByte;
                     lR := true;
                  end else if not lG then begin
                      lGreen := lByte;
                      lG := true;
                  end else if not lB then begin
                      lBlue := lByte;
                      //if (lIndex > 253) then showmessage(inttostr(lIndex));
                      lB := true;
                      gRra[lIndex] := lRed;
                      gGra[lIndex] := lGreen;
                      gBra[lIndex] := lBlue;
                      //if lIndex = 236 then showmessage(inttostr(lBlue));
                      ResetBools;
                  end;
              end;
              lNumStr := '';
         end;
     end;
     //until EOF(lF); //not eof
(*end osiris reader  *)
{write as ImageJ format  
     filemode := 1;
     lZ := 256;
     AssignFile(lFData, 'C:\Documents and Settings\Chris\My Documents\imagen\cortex.lut');
     Rewrite(lFData,1);
     BlockWrite(lFdata, gRra[1], lZ);   //red
     BlockWrite(lFdata, gGra[1], lZ); //blue
     BlockWrite(lFdata, gBra[1], lZ); //green
     CloseFile(lFData);
{end write}
     gMaxRGB := (gRra[255] + (gGra[255] shl 8)+(gBra[255] shl 16));
     gMinRGB := (gRra[0] + (gGra[0] shl 8)+(gBra[0] shl 16));
     closefile(lF);
     filemode := 2;
end;

procedure TMDIChild.FormClose(Sender: TObject; var Action: TCloseAction);
//release dynamic memory
begin
  gDynStr:= '';
  gSelectRect := rect(0,0,0,0);
  gSelectOrigin.X := -1;
  Action := caFree;
  MainForm.ColUpdate;
  gStringList.Free; //rev20
  ReleaseDICOMmemory;
  MainForm.UpdateMenuItems(nil);
end;

procedure TMDIChild.FormCreate(Sender: TObject);
//Initialize form
begin
     gSmooth := false;
     Smooth1.Checked := gSmooth;
     gMultiRow := 1;
     gMultiCol := 1;
     BackupBitmap := nil;
     gScheme := 1;
     gWinCen := 0;
     gWinWid := 0;
     gStringList := TStringList.Create;
     gFileListSz := 0;
     gCurrentPosInFileList := -1;
     gBuff16sz := 0;
     gVideoSpeed := 0;
     gBuff8sz := 0;
  FFileName    := '';
  gContrastStr := '';
  gDICOMdata.Allocbits_per_pixel := 0;
  gCustomPalette := 0;
  gMinHt := 10;
  gMinWid := 10;
  gDICOMData.XYZdim[1]        := 0;
  gDICOMData.XYZdim[2]       := 0;
  g100PctImageWid := 0;
  g100PctImageHt := 0;
  gZoomPct := 100;
  //for lInc := 0 to 255 do
  //    gRGBquadRA[lInc].rgbReserved := 0;
end;

procedure TMDIChild.DetermineZoom;
//Work out scale of image.
//Can scale image to fit the form size
var lHZoom: single;
    lZoom,lZoomPct: integer;
begin
     if (not MainForm.BestFitItem.checked) then exit;
     lHZoom := (ClientWidth)/g100pctImageWid;
     if ((ClientHeight)/g100pctImageHt) < lHZoom then
        lHZoom := ((ClientHeight)/g100pctImageHt);
     lZoomPct := trunc(100*lHZoom);
     if lZoomPct < 11 then
        lZoom := 10 //.5 zoom
     else if lZoomPct > 500 then
          lZoom := 500
     else lZoom := lZoomPct;
     gZoomPct := lZoom;
end;

procedure TMDIChild.AutoMaximise;
//Rescales image to fit form
var lZoom: integer;
begin
     if (not MainForm.BestFitItem.checked) or (g100pctImageHt < 1) or (g100pctImageWid < 1) then exit;
     lZoom := gZoomPct;
     DetermineZoom;
     if lZoom <> gZoomPct then begin
        RefreshZoom;
        MainForm.ZoomSlider.Position := lZoom;
     end;
end;

function FSize (lFName: String): longint;
var infp: file;
begin
     assign(infp,lFName);
     FileMode := 0; //Read only
     Reset(infp, 1);

     result := FileSize(infp);
     closefile(infp);
     Filemode := 2;