ezdicomimpl1.pas

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

  lINSz,  lDstWidM,x,y,lLT,lLB,lRT,lRB: integer;
  lXRatio,lYRatio: single;
begin
  yP:=0;
  lXRatio := lInXYRatio; //Note: in this implementation Height and Width have th same zoom factor: you could change this here!
  lYRatio := lInXYRatio; //Note: in this implementation Height and Width have th same zoom factor: you could change this here!
  lInSz := lSrcWid *lSrcHt;
  lPGwid := round(lSrcWid*lXRatio);
  lPGHt := round(lSrcHt*lYRatio);
  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 //24bit input generates 24bit output
    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;   //while x inner loop... for each column of data
      Inc(yP,yP2);
    end; //for y:=... for each row of data (once per scanline)
  end else if gCustomPalette > 0 then begin //8bit indexed color input, creates 24bit output
    lBits := 24;
    for y := 0 to 255 do begin //create local array for indexed colours: a bit faster
        lrRA[y] := grRA[y]; //red
        lgra[y] := ggRA[y]; //green
        lbra[y] := gbRA[y]; //blue
    end;
    getmem(lBuff, lPGHt*lPGWid*3);
    for y:=0 to lPGHt-1 do begin  //for each row/scanline
      xP:= 0;
      lTopPos:=lSrcWid *(yP shr 15);
      if yP shr 16<lSrcHt-1 then
         lBotPos:=lSrcWid *(yP shr 15+1)
      else
          lBotPos:=lTopPos;
      z2:=yP and $7FFF;
      iz2:=$8000-z2;
      x := 0;
      while x < lPGWid do begin //inner loop: each column
        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;   //while x.. inner loop: each column
      Inc(yP,yP2);
    end; //for y.. each row/scanline
  end else begin //8bit continuous input, generates 8bit output
    getmem(lBuff, lPGHt*lPGWid{*3});
    for y:=0 to lPGHt-1 do begin  //each row/scanline
      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 //each column
        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;   //while x: inner loop, each column
      Inc(yP,yP2);
    end; //for y: each row/scanline
end;  //<>24bits,custompal
end; //nested procedure ScaleStretch
//BELOW: variables for setdimension
var
   lByteRA: array[0..255] of byte;
   lBufferUsed: boolean;
   PixMap: pointer;
   Bmp     : TBitmap;
   hBmp    : HBITMAP;
   BI      : PBitmapInfo;
   BIH     : TBitmapInfoHeader;
   lSlope,lScale: single;
   lPixmapInt,lBuffInt: integer ;
   ImagoDC : hDC;
   lRow:  pRGBTripleArray;
   lTemp,lWinC,lWinW,lWinScaleShl16 ,
   lMinPal,lMaxPal,lL,lHt,lWid,I,J,lScanLineSz,lScanLineSz8: integer;
begin //begin setdimension
  FreeBackupBitmap;
  gLine.Left := -666;
  gLineLenMM := 0;
  DetermineZoom;
  lScale := gZoomPct / 100;
  lBits := lInBits;
  lBufferUsed := true;
  if (lScale = 1) or (not gSmooth) then begin
     lPGWid := lInPGWid;
     lPGHt := lInPGHt;
     lBuff := @lInBuff^;
     lBufferUsed := false;
  end else begin
     ScaleStretch(lInPGHt,lInPGWid, lScale);
  end;
  if (lBits = 24) then begin
     //next adjust contrast for 24-bit images
     if (gDICOMdata.RLERedSz <> 0) or (gDICOMdata.SamplesPerPixel > 1) or (gCustomPalette > 0) then begin
       lWinC := round(gWinCen);
       lWinW := round(gWinWid);
       //lStartTime := GetTickCount;
       if ((lWinC = 127) and (lWinW = 255)) or (lWinW = 0) then
         //contrast adjustment not required
       else begin
           if not lBufferUsed then begin
                getmem(lBuff, lPGHt*lPGWid*3);
                CopyMemory(Pointer(lBuff),Pointer(lInBuff),lPGHt*lPGWid*3);
                lBufferUsed := true;
           end;
           lWinScaleShl16 := 1 shl 16;
           lWinScaleShl16 := round (lWinScaleShl16*(256/lWinW));
           for lL := 0 to 255 do begin //lookup buffer for scaling
                lTemp := lL-lWinC;
                lTemp :=  (lTemp * lWinScaleShl16);
                lTemp := lTemp div 65536;
                lTemp := 128 +  lTemp;
                if lTemp < 0 then lTemp := 0
                else if lTemp > 255 then lTemp := 255;
                lByteRA[lL] := lTemp;
           end;
           J := (lPGWid * lPGHt * 3) -1;
            for lL := 0 to J do begin
                lBuff[lL] := lByteRA[lBuff[lL]];

            end;
       end; //contrast adjustment required
       //self.caption :=('update(ms): '+inttostr(GetTickCount-lStartTime)); //70 ms
        end;
        //end 24-bit contrast adjustment

        BMP := TBitmap.Create;
        TRY  //bitmap created
          lL := 0;
          BMP.PixelFormat := pf24bit;
          BMP.Width := lPGwid;
          BMP.Height := lPGHt;
          if lBuff <> nil then begin
            J := 0;
            REPEAT
             lRow := BMP.Scanline[j];
               FOR i := 0 TO BMP.Width-1 DO BEGIN //each column
                   WITH lRow[i] DO BEGIN
                     rgbtRed    := lBuff[lL];
                     inc(lL);
                     rgbtGreen := lBuff[lL];
                     inc(lL);
                     rgbtBlue  := lBuff[lL];
                     inc(lL);
                   END //with row
               END;  //for i: each column
                  Inc(J)
             UNTIL (J < 0) or (J >= BMP.Height); //for J: each row/scanline
          end; //if Buff <> nil
          Image.Picture.Graphic := BMP;
        FINALLY //BMP created
               BMP.Free;
        END; //if..finally for BMP created
        if (lBufferUsed) then //release any dynamically assigned memory
           freemem(lBuff);
        exit;
  end; //if 24bit: note EXIT in previous line: only 8 bit images dealt with in the rest of this procedure
  //8bit bitmap follows: first: create header
  BIH.biSize:= Sizeof(BIH);
  BIH.biWidth:= lPGwid;
  BIH.biHeight := lPGHt;
  BIH.biPlanes  := 1;
  BIH.biBitCount := 8;//Bits per pixel
  BIH.biCompression 	:= BI_RGB;
  BIH.biSizeImage := 0;
  BIH.biXPelsPerMeter := 0;
  BIH.biYPelsPerMeter := 0;
  BIH.biClrUsed       := 0;
  BIH.biClrImportant  := 0;
  {xx$P+,S-,W-,R-}
  BI := AllocMem(SizeOf(TBitmapInfoHeader) + 256*Sizeof(TRGBQuad));
  BI^.bmiHeader := BIH;
      if (gCustomPalette <> 0) and (gWinWid > 0) then begin
         //fargo
         lWinC := round(gWinCen);
         lWinW := round(gWinWid);
           lWinScaleShl16 := 1 shl 16;
           lWinScaleShl16 := round (lWinScaleShl16*(256/lWinW));
           for lL := 0 to 255 do begin
                lTemp := gRra[lL]-lWinC;
                lTemp :=  (lTemp * lWinScaleShl16);
                lTemp := lTemp div 65536;
                lTemp := 128 +  lTemp;
                if lTemp < 0 then lTemp := 0
                else if lTemp > 255 then lTemp := 255;
                BI^.bmiColors[lL].rgbRed     := lTemp;
                lTemp := gGra[lL]-lWinC;
                lTemp :=  (lTemp * lWinScaleShl16);
                lTemp := lTemp div 65536;
                lTemp := 128 +  lTemp;
                if lTemp < 0 then lTemp := 0
                else if lTemp > 255 then lTemp := 255;
                BI^.bmiColors[lL].rgbGreen    := lTemp;
                lTemp := gBra[lL]-lWinC;
                lTemp :=  (lTemp * lWinScaleShl16);
                lTemp := lTemp div 65536;
                lTemp := 128 +  lTemp;
                if lTemp < 0 then lTemp := 0
                else if lTemp > 255 then lTemp := 255;
                BI^.bmiColors[lL].rgbBlue      := lTemp;
                BI^.bmiColors[lL].rgbReserved := 0;
            end;
      end else
  if (gCustomPalette = 0) and (lUseWinCenWid) and (gWinWid > 0) then begin //clip continuous colors: load palette from red/green/blue arrays
        lMinPal := round(gWinCen - (gWinWid / 2{shr 1}));
        lMaxPal := round(lMinPal + gWinWid);
        lSlope := 255 / gWinWid;
        if (lMinPal < 0) or (lMinPal > 255) then
           lMinPal := 0;
        if (lMaxPal < 0) or (lMaxPal > 255) then
           lMaxPal := 255;
        for I := 0 to lMinPal do begin
                BI^.bmiColors[I].rgbRed     := gRra[0];
                BI^.bmiColors[I].rgbGreen    := gGra[0];
                BI^.bmiColors[I].rgbBlue      := gBra[0];
                BI^.bmiColors[I].rgbReserved := 0;
        end;
        for I := lMaxPal to 255 do begin
                BI^.bmiColors[I].rgbRed     := gRra[255];
                BI^.bmiColors[I].rgbGreen    := gGra[255];
                BI^.bmiColors[I].rgbBlue      := gBra[255];
                BI^.bmiColors[I].rgbReserved := 0;
        end;
        if (lMinPal+1) < (lMaxPal) then begin
            for I := (lMinPal+1) to (lMaxPal-1) do begin
                J := 128+round(lSLope*(I-gWinCen));
                if J < 0 then J := 0
                else if J > 255 then J := 255;
                BI^.bmiColors[I].rgbRed     := gRra[J];
                BI^.bmiColors[I].rgbGreen    := gGra[J];
                BI^.bmiColors[I].rgbBlue      := gBra[J];
                BI^.bmiColors[I].rgbReserved := 0;
            end;
        end;
  end else begin //do not clip colors: load palette red/green/blue arrays
       for I:=0 to 255 do begin
             BI^.bmiColors[I].rgbRed     := gRra[i];
             BI^.bmiColors[I].rgbGreen    := gGra[i];
             BI^.bmiColors[I].rgbBlue      := gBra[i];
             BI^.bmiColors[I].rgbReserved := 0;
       end;
  end; //load either clipped or unclipped palette
  Bmp        := TBitmap.Create;
  Bmp.Height := lPGHt{width};
  Bmp.Width  := lPGwid;
  ImagoDC := GetDC(Self.Handle);
  hBmp:= CreateDIBSection(imagodc,bi^,DIB_RGB_COLORS,pixmap,0,0);
  lScanLineSz := lPGwid;
  if(lPGwid mod 4) <> 0 then
        lScanLineSz8 := 4*((lPGWid + 3)div 4)
  else
        lScanLineSz8 := lPGwid;
  lHt := Bmp.Height-1;
  //lWid := lPGwid -1;
  if lBuff <> nil then begin
     lPixmapInt  := Integer(pixmap);
     lBuffInt := Integer(lBuff);