console.pas

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

unit console;
interface
{$DEFINE notPNG} //If set to '{$DEFINE PNG}': support for PNG with Gustavo Daud's software: requires his libraries
// these PNG libraries are available from www.mricro.com/png.html
uses
  {$IFDEF PNG}pngImage,{$ENDIF}
  jpeg,
  Windows,SysUtils,Decompress,Dialogs,lsjpeg,dicom,
  classes,graphics,extctrls,FileCtrl,define_types,shellAPI;
//choose Run/Parameters to test sample configurations, for example:
//                      " -z 1.5 -c 255 -b 100 d:\rgb.dcm"
(*
DCM2JPG medical image converter
Copyright (c) 2002, Wolfgang Krug and Chris Rorden
All rights reserved.

Redistribution and use in source and binary forms, with or without modification,
are permitted provided that the following conditions are met:

Redistributions of source code must retain the above copyright notice, this list
of conditions and the following disclaimer.

Redistributions in binary form must reproduce the above copyright notice, this
list of conditions and the following disclaimer in the documentation and/or
other materials provided with the distribution.

Neither the names of the copyright owners nor the names of this project
(DCM2JPG) may be used to endorse or promote products derived from this software
without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)
procedure MainLoop;
implementation
const
     kMaxECAT = 512;
     gZoomPct: integer = 100;
     gSmooth: boolean = true;
     kJPEG = 0;
     kPNG = 1;
     kBMP = 2;
     kTXT = 3;
     gOutputFormat : integer = kJPEG;
     gIntenScaleInt : integer = 1;
     gIntenInterceptInt : integer = 0;
     gIntRescale : boolean= true;
     gOverwriteAlertShown: boolean = false;
var
   gABort,gUseRecommendedContrast,gSilent: boolean;
   gOutDir: string;
   gDICOMdata: dicomdata;
   gECATposra,gECATszra: array[0..kMaxECAT] of longint;
   gBuff16: SmallIntP0;
   gBuff8,gBuff24: Bytep0;
   gECATslices: integer;
   gImgMin,gImgMax,gImgCen,gImgWid,
   gJPEGQuality,gWinMin,gWinMax,gWinCen,gWinWid,
   g100pctImageWid,g100pctImageHt,gSLice,
   gMultiROw,gMultiCol,gMultiFirst,gMultiLast,
   gVideoSpeed,gBuff24sz,gBuff8sz, gBuff16sz,gCustomPalette,
   gFastSlope,gFastCen: integer;
   gPalRA,gRra,gGra,gBra: array [0..255] of byte;

procedure RescaleClear; //15za
begin
     gIntenScaleInt := 1;
     gIntenInterceptInt := 0;
     gIntRescale := true;
end;

procedure RescaleInit; //15za
var lS,lI: single;
 lSi, lIi: integer;
begin
     RescaleClear;
     if gDICOMdata.IntenScale = 0 then
        gDICOMdata.IntenScale := 1;
     lS := gDICOMdata.IntenScale;
     lI := gDICOMdata.IntenIntercept;
     lSi := round(lS);
     lIi := round(lI);
     if (lS=lSi) and (lI=lIi) then begin
        gIntenScaleInt := lSi;
        gIntenInterceptInt := lIi;
        gIntRescale := true;
     end else
         gIntRescale := false;
end;

function RescaleFromBuffer(lIn:integer):integer; //15za
begin
     if gIntRescale then
        result := round((lIn*gIntenScaleInt)+ gIntenInterceptInt)
     else
          result := round((lIn*gDICOMdata.IntenScale)+ gDICOMdata.intenIntercept);
end;

function RescaleToBuffer(lIn:integer):integer; //15za
begin
     result := round((lIn/gDICOMdata.IntenScale)- gDICOMdata.intenIntercept);
end;


procedure   ReleaseDICOMmemory;
begin
  if (gBuff24sz > 0) then begin
     freemem(gBuff24);
     gBuff24sz := 0;
  end;
  if (gBuff16sz > 0) then begin
     freemem(gBuff16);
     gBuff16sz := 0;
  end;
  if (gBuff8sz > 0) then begin
     freemem(gBuff8);
     gBuff8sz := 0;
  end;
     if red_table_size > 0 then begin
        freemem(red_table);
        red_table_size := 0;
     end;
     if green_table_size > 0 then begin
        freemem(green_table);
        green_table_size := 0;
     end;
     if blue_table_size > 0 then begin
        freemem(blue_table);
        blue_table_size := 0;
     end;
     gCustomPalette := 0;
     gECATslices:= 0;
end;

procedure SaveTxt (var lFilename,lDynStr: string);
var
   lOutNum,lOutName,lOutput: string;
   lLen,lInc: integer;
   lTextFile: TextFile;
begin
     if gAbort then exit;
     lOutName := ChangeFileExt(lFileName,'');
     if length(gOutDir) < 2 then begin
        lOutNum := extractfiledir(lFilename);
        if lOutNum[length(lOutNum)] <> '\' then
           lOutNum := lOutNum + '\';
        lOutName := lOutNum+extractfilename(lOutName)
     end else
         lOutName := gOutDir+extractfilename(lOutName);
     lOutName :=lOutName+'.txt';
     if not gSilent then begin
        if not gOverwriteAlertShown then begin
           if fileexists(lOutname) then begin
              case MessageDlg('The file '+lOutname+' already exists. Do you wish to overwrite all orignal images?',mtError,[mbOK,mbAbort],0) of
                   id_Abort: gAbort := true;
              end; //case message
              gOverwriteAlertShown := true;
              if gAbort then exit;
           end;
        end;
        Writeln('1 Creating: '+lOutName);
     end; //silent
     //next: add eoln markers: convert 0d to 0d0a pairs
     lLen := length(lDynStr);
     lOutPut := '';
     for lInc := 1 to lLen do begin
         lOutput := lOutput + lDynStr[lInc];
         if lDynStr[lInc] = chr($0d) then
            lOutput := lOutput + chr($0a);
     end;
     //next: save to disk


              assignfile(lTextFile,lOutName);
              rewrite(lTextFile);
              write(lTextFile,lOutPut);
              closefile(lTextFile);

end;

procedure Save2Disk (lPGWid,lPGHt: integer; var lInBMP: TBitmap; var lFilename: string);
var
   lI,lDigits,lMaxDigits: integer;
   lBMP : tBitmap;
   lJPG: TJPEGImage;
   lOutName,lOutnum: string;
begin
     if gAbort then exit;
     lOutName := ChangeFileExt(lFileName,'');
     if length(gOutDir) < 2 then begin
        lOutNum := extractfiledir(lFilename);
        if lOutNum[length(lOutNum)] <> '\' then
           lOutNum := lOutNum + '\';
        lOutName := lOutNum+extractfilename(lOutName)
     end else
         lOutName := gOutDir+extractfilename(lOutName);
     //showmessage(lOutname+inttostr(gDICOMData.XYZdim[3]));
     if gDICOMData.XYZdim[3] > 1 then begin
           lMaxDigits := length(inttostr(gDICOMData.XYZdim[3]));
           lOutNum := inttostr(gSlice);
           lDigits := length(lOutNum);
           if lDigits < lMaxDigits then
              for lI := (lDigits+1) to lMaxDIgits do
                  lOutnum := '0'+lOutnum;

           lOutName := lOutname + lOutNum;
     end;
     case gOutputFormat of
         KBMP: lOutName :=lOutName+'.bmp';
         kPNG: lOutName :=lOutName+'.png';
         else lOutName :=lOutName+'.jpg';
     end; //case format
     if not gSilent then begin
        if not gOverwriteAlertShown then begin
           if fileexists(lOutname) then begin
              case MessageDlg('The file '+lOutname+' already exists. Do you wish to overwrite all orignal images?',mtError,[mbOK,mbAbort],0) of
                   id_Abort: gAbort := true;
              end; //case message
              gOverwriteAlertShown := true;
              if gAbort then exit;
           end;
        end;
        Writeln('1 Creating: '+lOutName);
     end; //silent
     case gOutputFormat of
         KBMP: begin
              lInBMP.SaveToFile({ChangeFileExt(lOutName,'.bmp'}lOutName);
               end;
     {$IFDEF PNG}
         kPNG: begin
           with TPNGImage.Create do begin
                Filter := [efNone];
                Assign(lInBMP);
                SaveToFile({ChangeFileExt(lOutName,'.png')}lOutName);
                free;
           end;
         end;//case = PNG
     {$ENDIF}
         else begin //JPEG output
            lBMP := TBitmap.create;
              try
                 lBMP.PixelFormat := pf24bit;
                 lBMP.Height := lPGHt;
                 lBMP.Width := lPGwid;
                 lBMP.Canvas.Draw(0,0, lInBMP);
                 lJPG := TJPEGImage.Create;
                 TRY
                    lJPG.CompressionQuality := gJPEGQuality;
                    lJPG.Assign(lBMP);
                    lJPG.SaveToFile({ChangeFileExt(lOutName,'.jpg')}lOutName);
                 FINALLY
                        lJPG.Free
                 END; //finally...
              finally
                     lBMP.Free;
              end; //finally
         end; //jpeg format
     end; //case gOutputFormat
end; //procedure SaveJPEG

procedure SetDimension(lInPGHt,lInPGWid ,lInBits:integer; lInBuff: ByteP0; lUseWinCenWid: boolean;var  lFilename: string);
var
  lBuff: ByteP0;
  lPGwid,lPGHt,lBits: integer;
procedure ScaleStretch(lSrcHt,lSrcWid: integer; lInXYRatio: single);
var
lKScale: byte;
lrRA,lbRA,lgRA: array [0..255] of byte;
  //lBuff: ByteP0;
  lPos,xP,yP,yP2,xP2,t,z, z2,iz2,w1,w2,w3,w4,lTopPos,lBotPos,
  lINSz,  lDstWidM,{lDstWid,lDstHt,}x,y,lLT,lLB,lRT,lRB: integer;
    lXRatio,lYRatio: single;
  begin
  yP:=0;
  lXRatio := lInXYRatio;
  lYRatio := lInXYRatio;
  lInSz := lSrcWid *lSrcHt;
  lPGwid := {round}round(lSrcWid*lXRatio);//*lZoom;
  lPGHt := {round}round(lSrcHt*lYRatio);//*lZoom;
  lkScale := 1;
  xP2:=((lSrcWid-1)shl 15)div (lPGWid -1 );
  yP2:=((lSrcHt-1)shl 15)div (lPGHt -1);
  lPos := 0;
  lDstWidM := lPGWid - 1;
  if lBIts = 24 then begin
  getmem(lBuff, lPGHt*lPGWid*3);
  lInSz := lInSz * 3; //24bytesperpixel
  for y:=0 to lPGHt-1 do begin
      xP:= 0;
      lTopPos:=lSrcWid *(yP shr 15) *3; //top row
      if yP shr 16<lSrcHt-1 then
         lBotPos:=lSrcWid *(yP shr 15+1) *3 //bottom column
      else
          lBotPos:=lTopPos;
      z2:=yP and $7FFF;
      iz2:=$8000-z2;
      x := 0;
      while x < lPGWid do begin
        t:=(xP shr 15) * 3;
        if ((lBotPos+t+6) > lInSz) or ((lTopPos+t) < 0) then begin
           lBuff[lPos] :=0; inc(lPos); //reds
           lBuff[lPos] :=0; inc(lPos); //greens
           lBuff[lPos] :=0; inc(lPos); //blues
        end else begin
            z:=xP and $7FFF;
            w2:=(z*iz2)shr 15;
            w1:=iz2-w2;
            w4:=(z*z2)shr 15;
            w3:=z2-w4;
            lBuff[lPos] :=(lInBuff[lTopPos+t]*w1+lInBuff[lTopPos+t+3]*w2
            +lInBuff[lBotPos+t]*w3+lInBuff[lBotPos+t+3]*w4)shr 15;
            inc(lPos); //reds
            lBuff[lPos] :=(lInBuff[lTopPos+t+1]*w1+lInBuff[lTopPos+t+4]*w2
            +lInBuff[lBotPos+t+1]*w3+lInBuff[lBotPos+t+4]*w4)shr 15;
            inc(lPos); //greens
            lBuff[lPos] :=(lInBuff[lTopPos+t+2]*w1+lInBuff[lTopPos+t+5]*w2
            +lInBuff[lBotPos+t+2]*w3+lInBuff[lBotPos+t+5]*w4)shr 15;
            inc(lPos); //blues
        end;
        Inc(xP,xP2);
        inc(x);
      end;   //inner loop
      Inc(yP,yP2);
    end;
end else if gCustomPalette > 0 then begin //<>24bits,custompal
   lBits := 24;
   for y := 0 to 255 do begin
    lrRA[y] := grRA[y];
    lgra[y] := ggRA[y]  ;
    lbra[y] := gbRA[y];
   end;
  getmem(lBuff, lPGHt*lPGWid*3);
  for y:=0 to lPGHt-1 do begin
      xP:= 0;
      lTopPos:=lSrcWid *(yP shr 15);  //Line1
      if yP shr 16<lSrcHt-1 then
         lBotPos:=lSrcWid *(yP shr 15+1)   //Line2
      else
          lBotPos:=lTopPos;//lSrcWid *(yP shr 15);
      z2:=yP and $7FFF;
      iz2:=$8000-z2;
      x := 0;
      while x < lPGWid do begin
        t:=xP shr 15;
      if ((lBotPos+t+2) > lInSz) or ((lTopPos+t{-1}) < 0) then begin
        lLT := 0;
        lRT := 0;
        lLB := 0;
        lRB := 0;
      end else begin
        lLT := lInBuff[lTopPos+t];