qdcmimage.pas

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

  //lBMP: TBitmap;
  //lOutF: file;
  //lP: ByteP;
//123  lJPEGImage: TJPEGIMage;
  //lB: pByteArray;//bytep;
  lUpExt,lFileExt,lBaseFilenameWOPath,lBaseFileName: String;
  lWideString : WideString;
  {lPadLen,}lInc{,lnImages,lSz,lHt,lI,lJ,lLineLen,lBMPLen}: integer;
function ParseFileName (lFilewExt:String): string;
var
   lLen,lInc: integer;
   lName: String;
begin
	lName := '';
     lLen := length(lFilewExt);
	lInc := lLen+1;
     if  lLen > 0 then
	   repeat
              dec(lInc);
        until (lFileWExt[lInc] = '.') or (lInc = 1);
     if lInc > 1 then
        for lLen := 1 to (lInc - 1) do
            lName := lName + lFileWExt[lLen]
     else
         lName := lFilewExt; //no extension
        ParseFileName := lName;
end;
(*function PadStr (lValIn, lPadLenIn: integer): string;
var lOrigLen,lPad : integer;
begin
 lOrigLen := length(inttostr(lValIn));
 result := inttostr(lValIn);
 if lOrigLen < lPadLenIn then begin
    lOrigLen := lPadLenIn-lOrigLen;
    for lPad := 1 to lOrigLen do
        result := '0'+result;
 end;
end;*)
begin
  //if (gPGHt <1) or (gPGWid < 1) or (PGImage.Picture.Graphic = nil) then begi
  IF gFilename = '' then begin
    Showmessage('You need to load an image before you can save a bitmap.');
    exit;
  end;
  lWideString := lFilename;
  lFileExt := extractfileExt(lWideString);
  lUpExt := '';
  if Length(lFileExt) > 0 then
   for lInc := 1 to Length(lFileExt) do
        if (lFileExt[lInc]<> '.') then
                lUpExt := lUpExt + UpCase(lFileExt[lInc]);
  if lUpExt = 'JPG' then lUpExt := 'JPEG';
  if (lUpExt <> 'JPEG') and (lUpExt <> 'PNG') and (lUpExt <> 'BMP') then begin
        lUpExt := 'PNG';
        //Showmessage(lWideString);
        lWideString := lWideString+'.PNG';
        //ChangeFileExt(lWideString,'.PNG');
        //Showmessage(lWideString);
  end;
  lBaseFilenameWOPath := ParseFileName(ExtractFileName(lWideString));
  lBaseFilename :=  ExtractFilePath(lWideString)+lBaseFilenameWOPath;
     if lUpExt = 'JPEG' then
        QPixMap_save(Self.Picture.Bitmap.Handle,@lWideString,PChar(lUpExt),75 {compression level})
     else
        QPixMap_save(Self.Picture.Bitmap.Handle,@lWideString,PChar(lUpExt));
end;

procedure   TDCMimage.ReleaseDICOMmemory;
begin
  FreeBackupBitmap;
  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 TDCMimage.SetDimension(lInPGHt,lInPGWid ,lInBits:integer; lInBuff: ByteP0; lUseWinCenWid: boolean);
//procedure TMainForm.SetDimension(lInPGHt,lInPGWid,lInBits:integer; lInBuff: ByteP;lRevScanLine24b: boolean);
var
  lBufferUsed: boolean;
  lByteRA: array[0..255] of byte;
  lBuff: ByteP0;//roxy -> was bytep0
  lPGwid,lPGHt,lBits: integer;
   Bmp     : TBitmap;
      lSlope,lScale: single;
   lRGB32ra: array [0..255] of longword;
   lRow32: pRGB32ra;
   lWinScaleShl16,lWinC,lWinW: integer;
   lRow: pRGBQuadArray; //pRGBTripleArray;
   lMinPal,lMaxPal,lTemp,
   lL,I,J: 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];
        lRT := lInBuff[lTopPos+t+1];
        lLB := lInBuff[lBotPos+t];
        lRB := lInBuff[lBotPos+t+1];
      end;
        z:=xP and $7FFF;
        w2:=(z*iz2)shr 15;
        w1:=iz2-w2;
        w4:=(z*z2)shr 15;
        w3:=z2-w4;
        lBuff[lPos] :=(lrRA[lLT]*w1+lrRA[lRT]*w2
        +lrRA[lLB]*w3+lrRA[lRB]*w4)shr 15;
        inc(lPos);
        lBuff[lPos] :=(lgRA[lLT]*w1+lgRA[lRT]*w2
        +lgRA[lLB]*w3+lgRA[lRB]*w4)shr 15;
        inc(lPos);
        lBuff[lPos] :=(lbRA[lLT]*w1+lbRA[lRT]*w2
        +lbRA[lLB]*w3+lbRA[lRB]*w4)shr 15;
        inc(lPos);
        Inc(xP,xP2);
        inc(x);
      end;   //inner loop
      Inc(yP,yP2);
    end;
end else begin //<>24bits,custompal
  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;
      //      for x:=0 to lDstWid-1 do begin
      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{+1}];
        lRT := lInBuff[lTopPos+t{+2}+1];
        lLB := lInBuff[lBotPos+t{+1}];
        lRB := lInBuff[lBotPos+t{+2}+1];
      end;
        z:=xP and $7FFF;
        w2:=(z*iz2)shr 15;
        w1:=iz2-w2;
        w4:=(z*z2)shr 15;
        w3:=z2-w4;
        lBuff[lPos] :=(lLT*w1+lRT*w2
        +lLB*w3+lRB*w4)shr 15;
        inc(lPos);
        Inc(xP,xP2);
        inc(x);
      end;   //inner loop
      Inc(yP,yP2);
    end;
end;  //<>24bits,custompal
  end;

   (*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(lSrcWid*lXRatio);//*lZoom;
  lPGHt := 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];
        lRT := lInBuff[lTopPos+t+1];
        lLB := lInBuff[lBotPos+t];