console.pas

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

        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);
      //pc:=Dst.Scanlines[y];
      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;
var
   PixMap: pointer;
   lBufferUsed: boolean;
   Bmp     : TBitmap;
   hBmp    : HBITMAP;
   BI      : PBitmapInfo;
   BIH     : TBitmapInfoHeader;
   lSlope,lScale: single;
   lPixmapInt,lBuffInt: integer ;
   ImagoDC : hDC;
   lRow:  pRGBTripleArray;
   JPG: TJPEGImage;
   lByteRA: array[0..255] of byte;
   lBMP{,lBitmap}: TBitmap;
   lWinScaleShl16,lWinC,lWinW,lMinPal,lMaxPal,lL,lTemp,lHt,lWid,I,J,lScanLineSz,lScanLineSz8: integer;
begin
 lScale := gZoomPct / 100;
 lBits := lInBits;
 if (lScale = 1) or (not gSmooth) then begin
     lBufferUsed := false;
     lPGWid := lInPGWid;
     lPGHt := lInPGHt;
     lBuff := @lInBuff^;
 end else begin
     lBufferUsed := true;
    ScaleStretch(lInPGHt,lInPGWid, lScale);
 end;
 if (lBits = 24)  then begin
      if (gDICOMdata.RLERedSz <> 0)  or (gDICOMdata.SamplesPerPixel > 1) or (gCustomPalette > 0) then begin
       lWinC := gWinCen;
       lWinW := gWinWid;
       //lStartTime := GetTickCount;
       if ((lWinC = 127) and (lWinW = 255)) or (lWinW = 0) then
         //contrast scaling not required
       else begin //scale contrast/birghtness
            //showmessage(inttostr(lWinC)+'abbax'+inttostr(lWinW));
           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 scaling required
       //self.caption :=('update(ms): '+inttostr(GetTickCount-lStartTime)); //70 ms
      end;
        BMP := TBitmap.Create;
        lL := 0;
        TRY
           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
                   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 width
             //end; //horflip
               //if VertFlipItem.checked then
               //   Dec(J)
               //else
                  Inc(J)
           UNTIL (J < 0) or (J >= BMP.Height); //for J
        end;
           Save2Disk(lPGWid,lPGHt,BMP,lFilename);
        FINALLY
               BMP.Free;
        END;
        if lBufferUsed then
           freemem(lBuff);
        exit;
     end;  //24bit
     Bmp        := TBitmap.Create;
     Bmp.Height := lPGHt{width};
     Bmp.Width  := lPGwid;
     BIH.biSize:= Sizeof(BIH);
     BIH.biWidth:= lPGwid;//g100pctImageWid{width};
     BIH.biHeight := lPGHt{-height};
     BIH.biPlanes  := 1;
     BIH.biBitCount := 8;//lBits;
     BIH.biCompression 	:= BI_RGB;
     BIH.biSizeImage := 0;
     BIH.biXPelsPerMeter := 0;
     BIH.biYPelsPerMeter := 0;
     BIH.biClrUsed       := 0;
     BIH.biClrImportant  := 0;
     //{$P+,S-,W-,R-}
     BI := AllocMem(SizeOf(TBitmapInfoHeader) + 256*Sizeof(TRGBQuad));
     BI^.bmiHeader := BIH;
     if (gCustomPalette > 0) and (gWinWid > 0) then begin
         lWinC := gWinCen;
         lWinW := 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 (lUseWinCenWid) and (gWinWid > 0) then begin
        //if lMin < 0 then lMin := 0

        //lMin > 255 then lMin := 255;
        //if lMax < 0 then lMax := 0
        //else if lMax > 255 then lMax := 255;
        lMinPal := gWinCen - (gWinWid shr 1);
        lMaxPal := 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 //use wincen/wid
       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; //use wincen/wid
     hBMP{.Handle} := CreateDIBSection( BMP.Canvas.Handle, 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;
     if lBuff <> nil then begin
        lPixmapInt  := Integer(pixmap);
        lBuffInt := Integer(lBuff);
           For i:= (lHt)  downto 0 do
               CopyMemory(Pointer(lPixmapInt+lScanLineSz8*(i)),
                     Pointer(lBuffInt+((lHt-i))*lScanLineSz),lScanLineSz);
     end; //lBuff full
     //ReleaseDC(0,ImagoDC);
     ReleaseDC(0,BMP.Canvas.Handle);
     Bmp.Handle := hBmp;
     Save2Disk(lPGWid,lPGHt,BMP,lFilename);
     Bmp.ReleasePalette;
     Bmp.Free;
     FreeMem( BI);
     //if (lScale <> 1) and (gSmooth) then
     if lBufferUsed then
        freemem(lBuff);
end;

procedure Scale16to8bit(lWinCen,lWinWid: integer; var lFIlename: string);
var
   lCen,lWid,value,i,lScaleShl10,lSz,min16,max16  :integer;
   lBuffx: ByteP0;
begin
  if gBuff16 = nil then exit;
  gWinCen := lWinCen;
  gWinWid := lWinWid;
  (*nothere if Self.Active then begin//qwer
     gContrastStr := 'Window Center/Width: '+inttostr(lWinCen)+'/'+inttostr(lWinWid){+':'+inttostr(round(lSlopeReal))};
     MainForm.StatusBar.Panels[4].text := gContrastStr;
  end; *)
  //if lWinWid{Edit.value} <> 0 then begin
  //    min16 := lWinCen{Edit.value} - (abs(trunc(lWinWid{Edit.value}/2)));
  //    max16 := lWinCen{Edit.value} + (abs(trunc(lWinWid{Edit.value}/2)));
  //end;
  lCen := RescaleToBuffer(lWinCen);
  lWid := abs(trunc((lWinWid/ gDICOMdata.IntenScale) /2));
  min16 := lCen - lWid;//15za
  max16 := lCen + lWid;//15za
  gWinMin := min16;
  gWinMax := max16;
  lSz:= (g100pctImageWid*g100pctImageHt);
  GetMem( lbuffx,lSz {width * height});
  lSz := lSz -1;
  value := (max16-min16);
  //value = range
  if (value = 0) or (trunc((1024/value) * 255) = 0) then begin
      if lWinWid > 1024 then begin
         for i := 0 to lSz do
          lbuffx[i] := 128;

      end else begin
      for i := 0 to lSz do
          if gBuff16[i] < lWinCen then
             lbuffx[i] := 0
          else
               lbuffx[i] := 255;
      end;
  end else begin
      if value = 0 then value := 1;
      lScaleShl10 := trunc((1024/value) * 255); //value = range,Scale = 255/range
      for i := 0 to lSz do begin
          if gBuff16[i] < min16 then
             lbuffx[i] := 0
          else if gBuff16[i] > max16 then
               lbuffx[i] := 255
          else
              lbuffx[i] := (((gBuff16[i])-min16) * lScaleShl10)  shr 10;
            //NOTE: integer maths increases speed x7!
            //  	    lbuff[i] := (Trunc(255*((gBuff16[i])-min16) / (value)));
      end;
  end;
  SetDimension(g100pctImageHt,g100pctImageWid,8,lBuffx,false,lFilename);
  FreeMem( lbuffx );
end;



procedure DisplayImage(lUpdateCon,lForceDraw: boolean;lSlice,lInWinWid,lINWinCen: integer; var lInFilename: string);
label
123,444;
var
  Stream: TMemoryStream;
  Jpg: TJPEGImage;
  lWinWid,lWinCen,Hd: Integer;
  lLookup16,lCompressLine16: SmallIntP0;
  lMultiBuff,CptBuff,lBuff,TmpBuff   : bYTEp0;
  lPtr: Pointer;
  lRow:  pRGBTripleArray;
  lCptPos,lFullSz,lCompSz,lTmpPos,lTmpSz,lLastPixel: longint;
  lMultiSliceInc: single;
  lMultiMaxSlice,lMultiFullRowSz,lMultiCol,lMultiRow,lMultiStart,lMultiLineSz,lMultiSliceSz,lMultiColSz,lnMultiRow,lMultiSlice,lnMultiCol,lnMultiSlice: integer;
  lSmall: word;//smallint;
  l16Signed,l16Signed2 : smallint;
  lFileName: string;
  infp: file;
  max16 : LongInt;
  min16 : LongInt;
  lShort: ShortInt;
  lCptVal,lRunVal,lByte2,lByte: byte;
  lLineLen,{lScaleShl10,}lL,j,size,lScanLineSz,lBufEntries,lLine,lImgPos,lLineStart,lLineEnd,lPos,value,
  lInc,lCol,lXdim,lStoreSliceVox,lImageStart,lAllocSLiceSz,lStoreSliceSz,I,I12       : Integer;
  lY,lCb,lCr,lR,lG,lB: integer;
  hBmp    : HBITMAP;
  BI      : PBitmapInfo;