childwin.pas

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

            +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;
var
//lStartTime, lEndTime: DWord;
   lBufferUsed: boolean;
   PixMap: pointer;
   Bmp     : TBitmap;
   hBmp    : HBITMAP;
   BI      : PBitmapInfo;
   BIH     : TBitmapInfoHeader;
   lSlope,lScale: single;
   lPixmapInt,lBuffInt: integer ;
   ImagoDC : hDC;
   lByteRA: array[0..255] of byte;
   lRow:  pRGBTripleArray;
   lWinScaleShl16,
  lWinC,lWinW, lMinPal,lMaxPal,lL,lTemp,lHt,lWid,I,J,lScanLineSz,lScanLineSz8: integer;
begin
  gLine.Left := -666;
  gLineLenMM := 0;
 FreeBackupBitmap;
 lScale := gZoomPct / 100;
 lBits := lInBits;
 {rotate}
 

 if (lScale = 1) or (not gSmooth) then begin
     lPGWid := lInPGWid;
     lPGHt := lInPGHt;
     lBuff := @lInBuff^;
     lBufferUsed := false;
 end else begin
     lBufferUsed := true;
    ScaleStretch(lInPGHt,lInPGWid, lScale);
 end;
 if (lBits = 24) {or (lBits = 25)} then begin
   if (TMDIChild(MainForm.ActiveMDIChild).gDICOMdata.RLERedSz <> 0)  or (TMDIChild(MainForm.ActiveMDIChild).gDICOMdata.SamplesPerPixel > 1) or (TMDIChild(MainForm.ActiveMDIChild).gCustomPalette > 0) then begin
       lWinC := gWinCen;
       lWinW := gWinWid;
       //lStartTime := GetTickCount;
       if ((lWinC = 127) and (lWinW = 255)) or (lWinW = 0) then
         //scaling 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; //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
           //if VertFlipItem.checked then
           //   J := BMP.Height-1
           //else
              J := 0;
           REPEAT
             lRow := BMP.Scanline[j];
             {if HorFlipItem.checked then begin
               FOR i := BMP.Width-1 downto 0 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 else begin //horflip {}
               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;
           Image.Picture.Graphic := BMP;
        FINALLY
               BMP.Free;
        END;
        if (lBufferUsed) then //alpha1415ABBA: required
           freemem(lBuff);
        exit;
     end;  //24bit
     BIH.biSize:= Sizeof(BIH);
     BIH.biWidth:= lPGwid;
     BIH.biHeight := lPGHt;
     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 (TMDIChild(MainForm.ActiveMDIChild).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
        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
     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 (hBmp = 0) or (pixmap = nil) then
             if GetLastError = 0 then ShowMessage('Error!') else RaiseLastWin32Error;}
     if lBuff <> nil then begin
        {if HorFlipItem.checked then begin
           For i:= (lHt)  downto 0 do begin
               lPixMapInt := i * lScanLineSz;
               for j := (lWid shr 1) downto 0 do begin
                   lTemp :=lBuff[lPixMapInt+j];
                   lBuff[lPixMapInt+j] := lBuff[lPixMapInt+(lWid-j)];
                   lBuff[lPixMapInt+(lWid-j)] := lTemp;
               end;
           end; //i 0..lHt
        end; //horflip{}
        lPixmapInt  := Integer(pixmap);
        lBuffInt := Integer(lBuff);
        {if VertFlipItem.checked then begin
           For i:= (lHt)  downto 0 do
               CopyMemory(Pointer(lPixmapInt+lScanLineSz8*(i)),
                     Pointer(lBuffInt+((i))*lScanLineSz),lScanLineSz);
        end else begin}
           For i:= (lHt)  downto 0 do
               CopyMemory(Pointer(lPixmapInt+lScanLineSz8*(i)),
                     Pointer(lBuffInt+((lHt-i))*lScanLineSz),lScanLineSz);
        {end; {}
     end; //lBuff full
     ReleaseDC(0,ImagoDC);
     Bmp.Handle := hBmp;
     Bmp.ReleasePalette;

     Image.Picture.Assign(Bmp);
     Bmp.Free;
     FreeMem( BI);
     if (lBufferUsed) then begin
        freemem(lBuff);
     end;
     {$P-,S+,W+,R-}
end;

PROCEDURE TMDIChild.ShowMagnifier (CONST X,Y:  INTEGER);
//Shows a magnifier over one region of the image, saves old region a BackupBitmap
  VAR
    AreaRadius    :  INTEGER;
    Magnification :  INTEGER;
    xActual,yActual{,lMagArea}       :  INTEGER;
BEGIN