www.pudn.com > bitView.rar > BitView.pas
//=========================== *BIG* BITMAP VIEWER =====================
//
// The component is a desendant of TGraphicControl (just like a
// TPaintBox). I used the TGraphicControl rather than a TPaintBox
// to have control of the parent properties I wanted to publish.
//
// Version 1.00
// Grahame Marsh 19 January 1997
//
// Freeware - you get it for free, I take nothing, I make no promises!
//
// Please feel free to contact me: grahame.s.marsh@corp.courtaulds.co.uk
unit
BitView;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics,
Controls, Dialogs, Forms,dicom;
type
TBMPFilename = type string;
type
TTOverlaySet=(OHospitalName,OPatientName,OBoydyPart,OPatientChineseName,
OStudyID,OAnatomy,OContrast,OStudyDate,OStudyTime,
OManufacturer,OModelName,
OCouch,OSliceThick,OTilt,OKV,OMA,OMAS,OField,
OEchoTime,ORepTime,OFAngle,
OWinLev,OWinWid,ORule,OSrs,OAcq,OImg,OZoom); //OBoydyPart,OSrs,OAcq,OImg,OZoomliushiming添加
TOverlaySet=Set of TTOverlaySet;
TImageStatus=(ISNormal,ISPrint);
TCordi=(OXYmm,OZmm);//设置图像是在xy方向还是在Z方向的投影，为计算图像的长度 liushiming
TOverlayInfo=record
HospitalName,
PatientName,
BoydyPart,
PatientChineseName,
StudyID,
anatomy,
Contrast,
StudyDate,
StudyTime,
Manufacturer,
Modality,
ModelName,
Couch,
SliceThick,
Tilt,
KV,
MA,
MAS,
Field,
EchoTime,
RepTime,
FAngle,
SliceNo:string;
SeriesNum,AcquNum,ImageNum:integer;//liushiming
end;
type
ByteArray=array[0..0]of byte;
Pbyte=^ByteArray;
TColortable=array[0..767] of byte;
TPcolortable=^TColortable;
TBitViewer = class (TGraphicControl)
private
Colortable:TColortable;
FFileName: TBMPFilename; // bitmap filename, own type so it can
// have own prop editor
FBmpColor:integer; // Bmp is Monochrome or Color?
FPalette : HPalette; // handle to bitmap palette
FData : pointer; // pointer to start of data in memory
// mapped file
FBitmapWidth, // copy of bitmap width info for convience
FBitmapHeight, // copy of bitmap height info for convience
FBmpWidth, //User Set Bmp's Width
FBmpHeight, //User Set Bmp's Height
FBitmapXPelsPerMeter, // copy of bitmap X Pixels Per Meter
FBitmapYPelsPerMeter, // copy of bitmap Y Pixels Per Meter
FColours : integer; // number of colours in palette
FCentre, // centre the bitmap in the control
FStretch, // stretch the bitmap to fill the control
FAutoSize, // automatically size the control to
// display the bitmap
FActive : boolean; // true opens the viewer, false it's closed
FFileHeader : PBitmapFileHeader; // pointer to TBitmapFileHeader
// record
FInfoHeader : PBitmapInfoHeader; // pointer to TBitmapInfoHeader
// record
FInfo : PBitmapInfo; // pointer to the TBitmapInfo record
FPixelStart : pointer; // pointer to the start of the pixel data
Dest : TRect;
//Show Image Information
FImageTag:integer;
FImageTagActive:Boolean;
FImageSelect:Boolean;
FOverlaySet:TOverlaySet;
FOverlayInfo:TOverlayInfo;
FImageFontSize:integer;
FShowImageStatus:TImageStatus;
FShowOverlayBool:Boolean;
FShowScaleBool:Boolean;
FShowRightScaleBool:Boolean;//show图像右边动态比例尺 liushiming
FRuleSize,
FLeftOrientation,
FTopOrientation:string;
FHospitalLength:integer;
FCordiXYZmm:TCordi;//liushiming
FWinLev,
FWinWid:integer;
FScale:single;
FCenterIntX:Integer;
FCenterIntY:integer;
FXYZmm11:double; //设置比例尺x方向上的长度 liushiming
FXYZmm22:double;
FXYZmm33:double; //设置比例尺Z方向上的长度 liushiming
FOnImagePaint:TNotifyEvent;
procedure SetActive (Value : boolean);
procedure SetAutoSize (Value : boolean);
procedure SetFilename (const Value : TBMPFilename);
procedure SetStretch (Value : boolean);
procedure SetCentre (Value : boolean);
procedure SetDummyInt(Value:integer);
procedure SetBitmapWidth(Value : integer);
procedure SetBitmapHeight(Value : integer);
procedure SetWidth(Value: integer);
procedure SetHeight(Value: integer);
procedure SetBmpColor(Value: integer);
procedure SetColors(Value: integer);
procedure SetBmpInfo;
//Show Image Information
procedure SetImageTagActive(Value : Boolean);
procedure SetImageSelect(Value:Boolean);
procedure ShowImageTag;
procedure SetOverlayInfo(Value:TOverlayInfo);
procedure SetImageFontSize(Value:Integer);
procedure SetShowOverlayBool(Value:Boolean);
procedure SetShowScaleBool(value:Boolean);
procedure SetShowRightScaleBool(value:Boolean); //liushiming
procedure SetImageStatus(Value:TImageStatus);
procedure ShowOverlay;
procedure ShowRightScale; //liushiming
procedure ShowScale;
procedure ShowRule;
function GetImageCanvas:TCanvas;
function GetImageCanvasPenColor:TColor;
procedure SetImageCanvasPenColor(Value:TColor);
function GetImageCanvasPenWidth:integer;
procedure SetImageCanvasPenWidth(Value:integer);
function GetImageCanvasPenStyle:TPenStyle;
procedure SetImageCanvasPenStyle(Value:TPenStyle);
function GetImageCanvasBrushStyle:TBrushStyle;
procedure SetImageCanvasBrushStyle(Value:TBrushStyle);
procedure SetCordi(value:TCordi); //设置是什么方向的投影面XY OR Z
protected
procedure OpenViewer; virtual;
procedure CloseViewer; virtual;
procedure GetPalette; virtual;
procedure Changes; virtual;
public
Ptable:TPColortable;
constructor Create (AOwner : TComponent); override;
destructor Destroy; override;
procedure Paint; override;
procedure PaintFrames(left,top,right,bottom:integer);
procedure bmptextout(str:string;x,y,z:integer;color:TColor);
procedure BmpMoveTo(x,y:integer);
Procedure BmpLineTo(x,y,size,clr:integer;PStyle:TPenStyle);
procedure SaveToFile(FileName:string);
procedure SaveTobitmap(var bm:Tbitmap);
procedure BmpCopyToRect(DesRect:TRect;BmpTmp:TBitmap);
procedure LoadColorTableFromPointer(p:Pbyte);
procedure black;
procedure invert;virtual;
procedure Ellipse(X1, Y1, X2, Y2: Integer;Width:integer;Color:TColor;Style:TPenStyle);
procedure RectAngle(X1, Y1, X2, Y2: Integer;Width:integer;Color:TColor;Style:TPenStyle);
// open the viewer
procedure Close;
// close the viewer
procedure Open;
// pointer to the file header info
property BitmapFileHeader : PBitmapFileHeader read FFileHeader;
// pointer to the bitmap info header
property BitmapInfoHeader : PBitmapInfoHeader read FInfoHeader;
// pointer to the bitmap info
property BitmapInfo : PBitmapInfo read FInfo;
// pointer to the bitmap pixel data array
property PixelStart : pointer read FPixelStart;
// palette handle
property Palette : HPalette read FPalette;
property XYZmm1:double read FXYZmm11 write FXYZmm11; // liushiming
property XYZmm2:double read FXYZmm22 write FXYZmm22; // liushiming
property XYZmm3:double read FXYZmm33 write FXYZmm33; // liushiming
published
//READ-WRITE PROPS
// size control to bitmap
property AutoSize : boolean read FAutoSize write SetAutoSize default false;
// bitmap centred
property Centre : boolean read FCentre write SetCentre default false;
// filename of bitmap
property Filename : TBMPFilename read FFilename write SetFilename;
// stretch bitmap
property Stretch : boolean read FStretch write SetStretch default false;
// READ-ONLY PROPS
// number of colours in the bitmap palette
property Colours : integer read FColours write SetColors stored false;
// Bmp is Color or Monochrome
property BmpColor:integer read FBmpColor write SetBmpColor stored true;
// bitmap width
property BitmapHeight : integer read FBitmapHeight write SetBitmapHeight stored true;//liushiming
// bitmap height
property BitmapWidth : integer read FBitmapWidth write SetBitmapWidth stored true;//liushiming
// bitmap XPixelsPerMeter
property BitmapXPelsPerMeter: integer read FBitmapXPelsPerMeter write SetDummyInt stored false;
// bitmap YPixelsPerMeter
property BitmapYPelsPerMeter: integer read FBitmapYPelsPerMeter write SetDummyInt stored false;
//user Set Bmp's Width
property BmpWidth:integer read FBmpWidth write SetWidth stored true;
//User Set Bmp's Height
property BmpHeight:integer read FBmpHeight write SetHeight stored true;
property CordiXYZ:TCordi read FCordiXYZmm write FCordiXYZmm Default OXymm; //liusiming
// TGraphicControl PROPS NOW PUBLISHED
property Align;
property DragCursor;
property DragMode;
property Enabled;
property ParentShowHint;
property PopupMenu;
property ShowHint;
property Visible;
property OnClick;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDrag;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnStartDrag;
// viewer activate - stream active last!
property Active : boolean read FActive write SetActive default false;
//Show Image Information
property ImageTag:integer read FImageTag write FImageTag;
property ImageTagActive:Boolean read FImageTagActive write SetImageTagActive default false;
property ImageSelect:Boolean read FImageSelect write SetImageSelect default false;
property OverlaySet:TOverlaySet read FOverlaySet write FOverlaySet Default [];
property OverlayInfo:TOverlayInfo read FOverlayInfo write SetOverlayInfo;
property ImageFontSize:integer read FImageFontSize write SetImageFontSize default 12;
property ShowImageStatus:TImageStatus read FShowImageStatus write FShowImageStatus;
property ShowOverlayBool:Boolean read FShowOverlayBool write SetShowOverlayBool default True;
property ShowScaleBool:Boolean read FShowScaleBool write SetShowScaleBool default false;
property ShowRightScaleBool:Boolean read FShowRightScaleBool write SetShowRightScaleBool default false;
property RuleSize:string read FRuleSize write FRuleSize;
property LeftOrientation:string read FLeftOrientation write FLeftOrientation;
property TopOrientation:string read FTopOrientation write FTopOrientation;
property HospitalLength:integer read FHospitalLength write FHospitalLength;
property WinLev:integer read FWinlev write FWinlev;
property WinWid:integer read FWinWid write FWinWid;
property Scale:single read FScale write Fscale;
property CenterIntX:Integer read FCenterIntX write FCenterIntX;
property CenterIntY:Integer read FCenterIntY write FCenterIntY;
property ImageCanvas:TCanvas read GetImageCanvas ;
property ImageCanvasPenColor:TColor read GetImageCanvasPenColor write SetImageCanvasPenColor;
property ImageCanvasPenWidth:Integer read GetImageCanvasPenWidth write SetImageCanvasPenWidth;
property ImageCanvasPenStyle:TPenStyle read GetImageCanvasPenStyle write SetImageCanvasPenStyle;
property ImageCanvasBrushStyle:TBrushStyle read GetImageCanvasBrushStyle write SetImageCanvasBrushStyle;
property OnImagePaint:TNotifyEvent read FOnImagePaint write FOnImagePaint;
end;
procedure Register;
implementation
const
BitmapSignature = $4D42;
procedure InvalidBitmap;
begin
raise Exception.Create ('Bitmap image is not valid')
end;
procedure NotWhenActive;
begin
raise Exception.Create ('Not on an active big bitmap viewer')
end;
constructor TBitViewer.Create (AOwner : TComponent);
var
i:integer;
begin
inherited Create (AOwner);
Width := 150;
Height := 150;
ptable:=@Colortable;
for i:=0 to 255 do
begin
ptable[i]:=i;
ptable[i+256]:=i;
ptable[i+256*2]:=i;
end;
end;
destructor TBitViewer.Destroy;
begin
CloseViewer; // ensure file view is freed
inherited Destroy
end;
// This procedure takes the palette out of the bitmap. It references
// two values to do this (FColours - the colour count, and FInfo a
// pointer to TBitmapInfo record). This is a fairly standard way of
// getting a palette.If successful, FPalette contains a handle to a
// copy of the palette.
procedure TBitViewer.GetPalette;
var
SysPalSize,
Loop,
LogSize : integer;
LogPalette : PLogPalette;
DC : HDC;
Focus : HWND;
begin
FPalette := 0;
// fetch palette for colour bitmaps only
if FColours > 2 then
begin
// create palette from bitmap info
LogSize := SizeOf (TLogPalette) + pred(FColours) * SizeOf(TPaletteEntry);
LogPalette := AllocMem (LogSize);
try
with LogPalette^ do
begin
palNumEntries := FColours;
palVersion := $0300;
// I prefer to test programs with $R+, but this section of the program
// must be compiled with $R-. This $IFOPT enables the restoration of
// $R+ condition later on, but only if set now.
{$IFOPT R+}
{$DEFINE R_PLUS}
{$R-}
{$ENDIF}
Focus := GetFocus;
DC := GetDC (Focus);
try
SysPalSize := GetDeviceCaps (DC, SIZEPALETTE);
if (FColours = 16) and (SysPalSize >= 16) then
begin
GetSystemPaletteEntries (DC, 0, 8, palPalEntry);
loop := 8;
GetSystemPaletteEntries (DC, SysPalSize - loop, loop, palPalEntry[loop])
end else
with FInfo^ do
for loop := 0 to pred(FColours) do
begin
palPalEntry[loop].peRed :=bmiColors[loop].rgbRed;
palPalEntry[loop].peGreen :=bmiColors[loop].rgbGreen;
palPalEntry[loop].peBlue :=bmiColors[loop].rgbBlue
end
finally
ReleaseDC(Focus, DC)
end
{$IFDEF R_PLUS}
{$R+}
{$UNDEF R_PLUS}
{$ENDIF}
end;
FPalette := CreatePalette (LogPalette^)
finally
FreeMem (LogPalette, LogSize)
end
end
end;
procedure TBitViewer.OpenViewer;
{var
FileHandle,
MapHandle : THandle;}
begin
//if FActive then exit; //暂关liushimign
FBitmapHeight := FBmpHeight;//FInfoHeader^.biHeight;
FBitmapWidth := FBmpWidth;//FInfoHeader^.biWidth;
SetBmpInfo;
// get number of colours, above 256 colour files have FColours=0
with FInfoHeader^ do
if biClrUsed <> 0 then
FColours := biClrUsed
else
case biBitCount of
1,
4,
8 :begin
FColours := 1 shl biBitCount;
showmessage(inttostr(FColours));
end;
else
FColours := 0
end;
//get bitmap Pixels per Meter
FBitmapXPelsPerMeter :=FInfoHeader^.biXPelsPerMeter;
FBitmapYPelsPerMeter := FInfoHeader^.biYPelsPerMeter;
// fetch the palette
GetPalette;
// other setups
FActive := true;
Changes
end;
// The viewer PAINT method.
// -----
// The actions carried out here are:
// 1. If in design mode and not active put up a simple rectangle
// 2. Select and realize the bitmap palette
// 3. Calculate the bitmap image location taking into account the
// stretch and centre properties
// 4. Squirt the bitmap onto the canvas
// 5. Select the orginal palette
procedure TBitViewer.Paint;
var
OldPalette : HPalette;
hMemoryDC, hOldDC: HDC;
hBmp, hOldBmp: HBITMAP;
begin
try
hOldDC := Canvas.Handle;
hMemoryDC := CreateCompatibleDC(hOldDC);
Canvas.Handle := hMemoryDC;
hBmp := CreateCompatibleBitmap(hMemoryDC, Width, Height);
hOldBmp := SelectObject(hMemoryDC, hBmp);
with Canvas do
// simple rectangle for design mode
if (csDesigning in ComponentState) and not FActive then
begin
Pen.Style := psDash;
Brush.Style := bsClear;
Rectangle (0,0,Width, Height)
end else begin
// select the bitmap palette
if FPalette <> 0 then
OldPalette := SelectPalette (Handle, FPalette, false)
else
OldPalette := 0;
try
RealizePalette (Handle);
//liu 想把背景加黑
{StretchDIBits (Handle,
Left, Top,right, Bottom,
0, 0,width, height,
FPixelStart, FInfo^,
DIB_RGB_COLORS, SRCCOPY); }
// calculate the bitmap location
if FStretch then
Dest := ClientRect
else
if Centre then
Dest := Rect ((Width - FBitmapWidth) div 2, (Height - FBitmapHeight) div 2,
FBitmapWidth, FBitmapHeight)
else
Dest := Rect ( 0,0, FBitmapWidth, FBitmapHeight); //刘 改
// display it
with Dest do
StretchDIBits (Handle,
Left, Top,right, Bottom,
0, 0,FBitmapWidth, FBitmapHeight,
FPixelStart, FInfo^,
DIB_RGB_COLORS, SRCCOPY);
{ if FImageTagActive then
ShowImageTag;
if (FImageSelect) then
with Dest do
PaintFrames(Left,Top,Right,Bottom);
if FShowOverlayBool then
begin
ShowOverlay;
ShowRule;
end;}
finally
// put the old palette back in
if FImageTagActive then
ShowImageTag;
if (FImageSelect) then
with Dest do
PaintFrames(Left,Top,Right,Bottom);
if FShowOverlayBool then
begin
ShowOverlay;
ShowRule;
end;
if OldPalette <> 0 then
SelectPalette (Handle, oldPalette, false)
end;
end;
if Assigned(FOnImagePaint) then FOnImagePaint(self);
Canvas.Handle := hOldDC;
with Dest do
StretchDIBits (Canvas.Handle,
Left, Top, right, bottom,
0, 0, FBitmapWidth, FBitmapHeight,
FPixelStart, FInfo^,
DIB_RGB_COLORS, SRCCOPY);
if FImageTagActive then
ShowImageTag;
if (FImageSelect) then
with Dest do
PaintFrames(Left,Top,Right,Bottom);
if FShowOverlayBool then
begin
ShowOverlay;
ShowRule;
end;
if FShowScaleBool then
ShowScale;
if FShowRightScaleBool then //liushiming
ShowrightScale;
SelectObject(hMemoryDC, hOldBmp);
DeleteObject(hBmp);
DeleteObject(hMemoryDC);
except
end;
end;
procedure TBitViewer.SetColors(Value: integer);
begin
if FColours<>value then FColours:=value; //liushiming
end;
procedure TBitViewer.bmptextout(str:string;x,y,z:integer;color:TColor);
begin
with canvas do
begin
font.Size:=z;
font.color:=Color;
brush.Style:=bsclear;
textout(x,y,str);
end;
end;
procedure TBitViewer.PaintFrames(left,top,right,bottom:integer);
begin
With Canvas do
begin
pen.Color:=ClYellow;
pen.Width:=2;
Brush.Style:=bsClear;
Rectangle(Left,Top,Right,Bottom);
end;
end;
procedure TBitViewer.BmpMoveTo(x,y:integer);
begin
with canvas do
MoveTo(x,y);
end;
procedure TBitViewer.Ellipse(X1, Y1, X2, Y2: Integer;Width:integer;Color:TColor;Style:TPenStyle);
begin
with canvas do
begin
pen.Color:=color;
pen.Width:=2;
Pen.Style:=Style;
brush.style := bsclear;
Ellipse(X1, Y1, X2, Y2);
end;
end;
procedure TBitViewer.RectAngle(X1, Y1, X2, Y2: Integer;Width:integer;Color:TColor;Style:TPenStyle);
begin
with canvas do
begin
pen.Color:=color;
pen.Width:=2;
Pen.Style:=Style;
Brush.style := bsclear;
Rectangle(X1, Y1, X2, Y2);
end;
end;
procedure TBitViewer.BmpLineTo(x,y,Size,Clr:integer;PStyle:TPenStyle);
begin
with canvas do
begin
pen.Color:=Clr;
Pen.Width:=Size;
pen.Style:=PStyle;
pen.width:=Size;
LineTo(x,y);
end;
end;
procedure TBitViewer.SaveToFile(FileName:string);
var
R:TRect;
BmpTmp:Tbitmap;
begin
R.Left:=0;
R.top:=0;
R.Right:=FBitmapWidth;
R.Bottom:=FBitmapHeight;
BmpTmp:=TBitmap.Create;
Bmptmp.PixelFormat:=pf32bit;
BmpTmp.Width:=FBitMapWidth;
BmpTmp.Height:=FBitmapHeight;
BmpTmp.Canvas.CopyRect(R,Canvas,R);
BmpTmp.SaveToFile(FileName);
BmpTmp.Free;
end;
procedure TBitViewer.SaveTobitmap(var bm:Tbitmap);
var
R:TRect;
begin
R.Left:=0;
R.top:=0;
R.Right:=FBitmapWidth;
R.Bottom:=FBitmapHeight;
bm.Width:=FBitMapWidth;
bm.Height:=FBitmapHeight;
bm.Canvas.CopyRect(R,Canvas,R);
end;
procedure TBitViewer.BmpCopyToRect(DesRect:TRect;BmpTmp:TBitMap);
begin
BmpTmp.Canvas.CopyRect(DesRect,Canvas,Rect(0,0,FBitmapWidth,FBitmapHeight));
end;
procedure TBitViewer.invert;
var
OldPalette : HPalette;
Dest : TRect;
begin
with Canvas do
// simple rectangle for design mode
if (csDesigning in ComponentState) and not FActive then
begin
Pen.Style := psDash;
Brush.Style := bsClear;
Rectangle (0, 0, Width, Height)
end else begin
// select the bitmap palette
if FPalette <> 0 then
OldPalette := SelectPalette (Handle, FPalette, false)
else
OldPalette := 0;
try
RealizePalette (Handle);
// calculate the bitmap location
if FStretch then
Dest :=clientrect
else
if Centre then
Dest := Rect ((Width - FBitmapWidth) div 2, (Height - FBitmapHeight) div 2,
FBitmapWidth, FBitmapHeight)
else
Dest := Rect (0, 0, FBitmapWidth, FBitmapHeight);
// display it
with Dest do
StretchdiBits (Handle,
left,top,right,bottom,
0, 0, FBitmapWidth, FBitmapHeight,
FPixelStart, FInfo^,
DIB_RGB_COLORS,notsrccopy)
finally
// put the old palette back in
if OldPalette <> 0 then
SelectPalette (Handle, OldPalette, false)
end
end
end;
procedure TBitViewer.black;
var
OldPalette : HPalette;
Dest : TRect;
begin
with Canvas do
// simple rectangle for design mode
if (csDesigning in ComponentState) and not FActive then
begin
Pen.Style := psDash;
Brush.Style := bsClear;
Rectangle (0, 0, Width, Height)
end else begin
// select the bitmap palette
if FPalette <> 0 then
OldPalette := SelectPalette (Handle, FPalette, false)
else
OldPalette := 0;
try
RealizePalette (Handle);
// calculate the bitmap location
if FStretch then
Dest :=clientrect
else
if Centre then
Dest := Rect ((Width - FBitmapWidth) div 2, (Height - FBitmapHeight) div 2,
FBitmapWidth, FBitmapHeight)
else
Dest := Rect (0, 0, FBitmapWidth, FBitmapHeight);
// display it
with Dest do
StretchdiBits (Handle,
left,top,right,bottom,
0, 0, FBitmapWidth, FBitmapHeight,
FPixelStart, FInfo^,
DIB_RGB_COLORS,whiteness);
finally
// put the old palette back in
if OldPalette <> 0 then
SelectPalette (Handle, OldPalette, false)
end
end
end;
// close the viewer by unmapping the file, setting the view to nil and
// discarding the palette
procedure TBitViewer.CloseViewer;
begin
if FActive then
begin
FActive := false;
if FData <> nil then
begin
FreeMem(FData); // remove the memory mapped file view
FData := nil;
end;
if FPalette <> 0 then
DeleteObject (FPalette); // free the palette
FImageSelect:=false;
{FLeftOrientation:='';
FTopOrientation:='';
}
end;
end;
// set active to true
procedure TBitViewer.Open;
begin
Active := true
end;
// set active to false
procedure TBitViewer.Close;
begin
Active := false
end;
// Property Methods:
procedure TBitViewer.SetActive (Value : boolean);
begin
if Value <> FActive then
if Value then
OpenViewer
else
CloseViewer;
end;
procedure TBitViewer.SetAutoSize (Value : boolean);
begin
if Value <> FAutoSize then
begin
FAutoSize := Value;
Changes
end
end;
procedure TBitViewer.SetStretch (Value : boolean);
begin
if Value <> FStretch then
begin
FStretch := Value;
Changes
end
end;
procedure TBitViewer.SetCordi(value:TCordi); //liushiming
begin
if FCordiXYZmm<>value then
FCordiXYZmm:=Value;
end;
procedure TBitViewer.SetCentre (Value : boolean);
begin
if Value <> FCentre then
begin
FCentre := Value;
Changes
end
end;
procedure TBitViewer.SetFilename (const Value : TBMPFilename);
begin
if Value <> FFilename then
begin
if FActive then
NotWhenActive;
FFilename := Value
end
end;
// This dummy set integer procedure is used with the BitmapHeight and
// BitmapWidth properties to make them appear in the object inspector
// WITHOUT allowing them to be edited - ie readonly.
procedure TBitViewer.SetBitmapHeight (Value : integer);
begin
if FBitmapHeight<>value then
FBitmapHeight:=value;
end;
procedure TBitViewer.SetBitmapWidth(Value : integer);
begin
if FBitmapWidth<>value then
FBitmapWidth:=value;
end;
procedure TBitViewer.SetDummyInt(Value : integer);
begin
end;
procedure TBitViewer.SetWidth(Value: integer);
begin
if Value>=0 then
begin
FBmpWidth:=Value;
end;
end;
procedure TBitViewer.SetHeight(Value: integer);
begin
if Value>=0 then
begin
FBmpHeight:=Value;
end;
end;
procedure TBitViewer.SetBmpColor(Value: integer);
begin
FBmpColor:=value;
end;
procedure TBitViewer.LoadColorTableFromPointer(P: Pbyte);
var
i:integer;
begin
for i:=0 to 767 do
Ptable[i]:=P[i];
if active=true then
begin
active:=false;
active:=true;
end;
end;
procedure TBitViewer.SetBmpInfo;
var
i:integer;
begin
if FData<>nil then
begin
FreeMem(FData);
FData:=nil;
end;
if FBmpColor=3 then
begin
FData:=AllocMem(54+FBmpColor*FBmpWidth*FBmpHeight);
end else
begin
FData:=AllocMem(1078+FBmpColor*FBmpWidth*FBmpHeight);
end;
FFileHeader:=Pointer(FData);
with FFileHeader^ do
begin
bfType:=BitmapSignature; // 位图文件的类型，必须为BMliu
if FBmpColor=3 then
begin
bfSize:=54+FBmpColor*FBmpWidth*FBmpHeight;
bfoffBits:=54;
end else
begin
bfSize:=1078+FBmpColor*FBmpWidth*FBmpHeight;// 位图文件的大小，以字节为单位
bfOffBits:=1078; // 位图数据的起始位置，以相对于位图
end;
end;
FInfoHeader:=Pointer(integer(FData)+sizeof (TBitmapFileHeader));
FInfo:=Pointer(FInfoHeader);
FPixelStart:=Pointer(integer(FData)+FFileHeader^.bfoffBits);
with FInfoHeader^ do
begin
biSize:=40;// 本结构所占用字节数
biWidth:=FBmpWidth;// 位图的宽度，以像素为单位
biHeight:=FBmpHeight;// 位图的高度，以像素为单位
biPlanes:=1;// 目标设备的级别，必须为1
biBitCount:=FBmpColor*8;// 每个像素所需的位数，必须是1(双色), 4(16色)，8(256色)或24(真彩色)之一
biCompression:=0;// 位图压缩类型，必须是 0(不压缩), 1(BI_RLE8压缩类型)或2(BI_RLE4压缩类型)之一
biSizeImage:=FBmpColor*FBmpWidth*FBmpHeight;// 位图的大小，以字节为单位
biXPeLsPerMeter:=0; // 位图水平分辨率，每米像素数
biYPeLsPerMeter:=0; // 位图垂直分辨率，每米像素数
biClrUsed:=0; // 位图实际使用的颜色表中的颜色数
biClrImportant:=0;// 位图显示过程中重要的颜色数
end;
with FInfo^ do
begin
if FBmpColor=1 then
for i:=0 to 255 do
begin
bmiColors[i].rgbBlue:=ptable[i+2*256];
bmiColors[i].rgbGreen:=ptable[i+256];
bmiColors[i].rgbRed:=ptable[i];
bmiColors[i].rgbReserved:=0;
end
end;
end;
// Process changes to the TGraphicControl depending on size of
// the image compared to the form.
procedure TBitViewer.Changes;
begin
if (BitmapWidth >= Width) and (BitmapHeight >= Height) then
ControlStyle := ControlStyle + [csOpaque]
else
ControlStyle := ControlStyle - [csOpaque];
if AutoSize and (BitmapWidth > 0) and (BitmapHeight > 0) then
SetBounds (Left, Top, BitmapWidth, BitmapHeight)
else
Invalidate
end;
procedure TBitViewer.SetImageTagActive(Value : Boolean);
begin
if FImageTagActive<>Value then
begin
FImageTagActive:=Value;
if FActive then
Paint;
end;
end;
procedure TBitViewer.SetImageSelect(Value:Boolean);
begin
if FImageSelect<>Value then
begin
FImageSelect:=Value;
if FActive then
Paint;
end;
end;
procedure TBitViewer.ShowImageTag;
begin
with canvas do
begin
font.Size:=10;
font.color:=RGB(0,255,0);
brush.Style:=bsclear;
textout(1,1,IntToStr(FImageTag));
end;
end;
procedure TBitViewer.SetOverlayInfo(Value:TOverlayInfo);
begin
FOverlayInfo:=Value;
end;
procedure TBitViewer.SetImageFontSize(Value:integer);
begin
if (FImageFontSize<>Value) then
begin
FImageFontSize:=Value;
end;
end;
procedure TBitViewer.SetShowOverlayBool(Value:Boolean);
begin
if FShowOverlayBool<>Value then
begin
FShowOverlayBool:=Value;
end;
end;
procedure TBitViewer.SetShowScaleBool(Value:Boolean);
begin
if FShowScaleBool<>Value then
begin
FShowScaleBool:=Value;
end;
end;
procedure TBitViewer.SetShowRightScaleBool(value:Boolean);//显示右动态比例尺 liushiming
begin
if FShowRightScaleBool<>Value then
begin
FShowRightScaleBool:=Value;
end;
end;
procedure TBitViewer.SetImageStatus(Value:TImageStatus);
begin
if FShowImagestatus<>Value then
begin
FShowImageStatus:=Value;
if FActive then
Paint;
end;
end;
procedure TBitViewer.ShowScale;
var
centerx,centery:integer;
begin
centerx:=width div 2;
centery:=height div 2;
with Canvas do
begin
Pen.color:=rgb(255,0,0);
moveto(centerx,centery);
Lineto(centerx,centery+100);
Moveto(centerx,centery+20);
Lineto(centerx+10,centery+20);
Moveto(centerx,centery+40);
Lineto(centerx+10,centery+40);
Moveto(centerx,centery+60);
Lineto(centerx+10,centery+60);
Moveto(centerx,centery+80);
Lineto(centerx+10,centery+80);
Moveto(centerx,centery+100);
Lineto(centerx+10,centery+100);
textout(20,10,'100mm');
Moveto(centerx,centery);
Lineto(centerx+100,centery);
Moveto(centerx+20,centery);
Lineto(centerx+20,centery+10);
Moveto(centerx+40,centery);
Lineto(centerx+40,centery+10);
Moveto(centerx+60,centery);
Lineto(centerx+60,centery+10);
Moveto(centerx+80,centery);
Lineto(centerx+80,centery+10);
Moveto(centerx+100,centery);
Lineto(centerx+100,centery+10);
end;
end;
procedure TBitViewer.ShowRightScale; //liushiming
var
lx,ly,i:integer;
space,N,linelen:integer;
strlen:string;
begin
ly:=height div 4;
lx:=width - 18;
linelen:=0;
if scale<=0 then
scale:=1;
space:=round(scale*ly) div 10;
if space=0 then space:=1;
N:=2*ly div space;
with canvas do
begin
pen.Color:=clwhite;
pen.Width:=1;
brush.Style:=bsclear;
if FShowImageStatus=ISNormal then
font.color:=clwhite
else
if FShowImageStatus=ISPrint then
font.color:=RGB(255,255,255);
Font.Size:=FImageFontSize-2;
moveto(lx,ly);
lineto(lx+8,ly);
moveto(lx+8,ly);
lineto(lx+8,3*ly);
moveto(lx+8,3*ly);
lineto(lx,3*ly);
for i:=1 to N-1 do
begin
if (i mod 2)=0 then
linelen:=8
else
linelen:=4;
moveto(lx+8-linelen,ly+space*i );
lineto(lx+8,ly+space*i);
end;
if (FCordiXYZmm=Oxymm) then
strlen:=Format('%d cm',[round(FXYZmm22 * 0.2* ly / Fscale)])
else
if (FCordiXYZmm=Ozmm) then
strlen:=Format('%d cm',[round(fxyzmm33 * 0.2* ly / Fscale)]);
TextOut(Width-5-TextExtent(strlen).CX,3*ly+2,strlen);
end;
end;
procedure TBitViewer.ShowOverlay;
var
StrColor,RuleColor:TColor;
StrLeft,StrTop:integer;
StrTmp:string;
StrHeight:integer;
begin
with Canvas do
begin
if FShowImageStatus=ISNormal then
begin
StrColor:=RGB(0,255,200);
RuleColor:=RGB(0,255,0);
end else
if FShowImageStatus=ISPrint then
begin
StrColor:=RGB(255,255,255);
RuleColor:=RGB(255,255,255);
end;
StrLeft:=2;
StrTop:=2;
Font.Size:=FImageFontSize-2;
Font.Name:='MS Sans Serif';
Font.Color:=StrColor;
Brush.Style:=BsClear;
StrTmp:='PHOENIST';
StrHeight:=TextExtent(StrTmp).CY;
if (OHospitalName in FOverlaySet)and(Trim(FOverlayInfo.HospitalName)<>'') then
begin
SetLength(FOverlayInfo.HospitalName,FHospitalLength);
TextOut(StrLeft,StrTop,Trim(FOverlayInfo.HospitalName));
StrTop:=StrTop+StrHeight+2;
end;
Font.Size:=FImageFontSize;
StrHeight:=TextExtent(StrTmp).CY;
if (OPatientChineseName in FOverlaySet)and(Trim(FOverlayInfo.PatientChineseName)<>'') then
begin
TextOut(StrLeft,StrTop,Trim(FOverlayInfo.PatientChineseName));
StrTop:=StrTop+StrHeight;
end;
if (OPatientName in FOverlaySet)and(Trim(FOverlayInfo.PatientName)<>'') then
begin
TextOut(StrLeft,StrTop,Trim(FOverlayInfo.PatientName));
StrTop:=StrTop+StrHeight;
end;
if (OStudyID in FOverlaySet)and(Trim(FOverlayInfo.StudyID)<>'') then
begin
TextOut(StrLeft,StrTop,Trim(FOverlayInfo.StudyID)); //去掉了'ID:'文字
StrTop:=StrTop+StrHeight;
end;
if (OAnatomy in FOverlaySet)and(Trim(FOverlayInfo.anatomy)<>'') then
begin
TextOut(StrLeft,StrTop,Trim(FOverlayInfo.anatomy));
StrTop:=StrTop+StrHeight;
end;
if (OContrast in FOverlaySet)and(Trim(FOverlayInfo.Contrast)<>'') then
begin
TextOut(StrLeft,StrTop,'Const: '+Trim(FOverlayInfo.Contrast));
StrTop:=StrTop+StrHeight;
end;
if (OStudyDate in FOverlaySet)and(Trim(FOverlayInfo.StudyDate)<>'') then
begin
TextOut(StrLeft,StrTop,Trim(FOverlayInfo.StudyDate));
StrTop:=StrTop+StrHeight;
end;
if (OStudyTime in FOverlaySet)and(Trim(FOverlayInfo.StudyTime)<>'') then
begin
TextOut(StrLeft,StrTop,Trim(FOverlayInfo.StudyTime));
StrTop:=StrTop+StrHeight;
end;
StrTop:=Height-2*StrHeight-5;
if (OManufacturer in FOverlaySet)and(Trim(FOverlayInfo.Manufacturer)<>'') then
begin
TextOut(StrLeft,StrTop,Trim(FOverlayInfo.Manufacturer));
StrTop:=StrTop+StrHeight;
end;
if (OModelName in FOverlaySet)and(Trim(FOverlayInfo.ModelName)<>'') then
begin
TextOut(StrLeft,StrTop,Trim(FOverlayInfo.Modality)+': '+Trim(FOverlayInfo.ModelName));
StrTop:=StrTop+StrHeight;
end;
StrTop:=5;
if (OCouch in FOverlaySet)and(Trim(FOverlayInfo.Couch)<>'') then
begin
StrTmp:='Couch: '+Trim(FOverlayInfo.Couch);
StrLeft:=Width-5-TextExtent(StrTmp).CX;
TextOut(StrLeft,StrTop,StrTmp);
StrTop:=StrTop+StrHeight;
end;
if (OSliceThick in FOverlaySet)and(Trim(FOverlayInfo.SliceThick)<>'') then
begin
StrTmp:='Thick: '+Trim(FOverlayInfo.SliceThick);
StrLeft:=Width-5-TextExtent(StrTmp).CX;
TextOut(StrLeft,StrTop,StrTmp);
StrTop:=StrTop+StrHeight;
end;
if (OTilt in FOverlaySet)and(Trim(FOverlayInfo.Tilt)<>'')
and(Trim(FOverlayInfo.Modality)='CT') then
begin
StrTmp:='Tilt: '+Trim(FOverlayInfo.Tilt);
StrLeft:=BmpWidth-5-TextExtent(StrTmp).CX;
TextOut(StrLeft,StrTop,StrTmp);
StrTop:=StrTop+StrHeight;
end;
if (OKV in FOverlaySet)and(Trim(FOverlayInfo.KV)<>'')
and(Trim(FOverlayInfo.Modality)='CT') then
begin
StrTmp:='KV: '+Trim(FOverlayInfo.KV);
StrLeft:=Width-5-TextExtent(StrTmp).CX;
TextOut(StrLeft,StrTop,StrTmp);
StrTop:=StrTop+StrHeight;
end;
if (OMA in FOverlaySet)and(Trim(FOverlayInfo.MA)<>'')
and(Trim(FOverlayInfo.Modality)='CT') then
begin
StrTmp:='MA: '+Trim(FOverlayInfo.MA);
StrLeft:=Width-5-TextExtent(StrTmp).CX;
TextOut(StrLeft,StrTop,StrTmp);
StrTop:=StrTop+StrHeight;
end;
if (OMAS in FOverlaySet)and(Trim(FOverlayInfo.MAS)<>'')
and(Trim(FOverlayInfo.Modality)='CT') then
begin
StrTmp:='MAS: '+Trim(FOverlayInfo.MAS);
StrLeft:=Width-5-TextExtent(StrTmp).CX;
TextOut(StrLeft,StrTop,StrTmp);
StrTop:=StrTop+StrHeight;
end;
if (OField in FOverlaySet)and(Trim(FOverlayInfo.Field)<>'')
and(Trim(FOverlayInfo.Modality)='CT') then
begin
StrTmp:='Field: '+Trim(FOverlayInfo.Field);
StrLeft:=Width-5-TextExtent(StrTmp).CX;
TextOut(StrLeft,StrTop,StrTmp);
StrTop:=StrTop+StrHeight;
end;
if Trim(FOverlayInfo.SliceNo)<>'' then
begin
StrTmp:='第'+Trim(FOverlayInfo.SliceNo)+'幅';
StrLeft:=Width-5-TextExtent(StrTmp).CX;
TextOut(StrLeft,StrTop,StrTmp);
StrTop:=StrTop+StrHeight;
end;
StrTop:=Height-2*StrHeight-5;
if (OWinLev in FOverlaySet) then
begin
StrTmp:='L: '+inttostr(FWinlev);
StrLeft:=Width-5-TextExtent(StrTmp).CX;
TextOut(StrLeft,StrTop,StrTmp);
StrTop:=StrTop+StrHeight;
end;
if (OWinWid in FOverlaySet) then
begin
StrTmp:='W: '+inttostr(FWinWid);
StrLeft:=Width-5-TextExtent(StrTmp).CX;
TextOut(StrLeft,StrTop,StrTmp);
StrTop:=StrTop+StrHeight;
end;
strtop:=2;
if (Osrs in FOverlaySet) and (FOverlayInfo.SeriesNum>0) then //添加srssum,acqsum,imgsum liushiming
begin
StrTmp:=Format('Srs:%d',[FOverlayInfo.SeriesNum]);
strleft:=width-40;
TextOut(strleft,strtop,strtmp);
StrTop:=StrTop+StrHeight;
end;
if (OAcq in FOverlaySet) and (FOverlayInfo.AcquNum>0) then //添加srssum,acqsum,imgsum liushiming
begin
StrTmp:=Format('Acq:%d',[FOverlayInfo.AcquNum]);
strleft:=width-40;
TextOut(strleft,strtop,strtmp);
StrTop:=StrTop+StrHeight;
end;
if (OAcq in FOverlaySet) and (FOverlayInfo.ImageNum>0) then //添加srssum,acqsum,imgsum liushiming
begin
StrTmp:=Format('Img:%d',[FOverlayInfo.ImageNum]);
strleft:=width-40;
TextOut(strleft,strtop,strtmp);
end;
strTop:=Height div 2;
strleft:=2;
if (OMA in FOverlaySet)and(Trim(FOverlayInfo.Modality)<>'') then//检查设备 liushiming
begin
strtmp:=Trim(FOverlayInfo.Modality); //去掉了文字 'MD:'，因为文字太多使图显示区域变得很小
TextOut(StrLeft,StrTop,strtmp);
StrTop:=StrTop+StrHeight;
end;
if (OBoydyPart in FOverlaySet)and(Trim(FOverlayInfo.BoydyPart)<>'') then//检查部位 liushiming
begin
strtmp:=Trim(FOverlayInfo.BoydyPart); //去掉了文字 'PART:'，因为文字太多使图显示区域变得很小
TextOut(StrLeft,StrTop,strtmp);
StrTop:=StrTop+StrHeight;
end;
StrTop:=Height-3*StrHeight-5;
if (OEchoTime in FOverlaySet)and(Trim(FOverlayInfo.EchoTime)<>'')
and(Trim(FOverlayInfo.Modality)='MR') then
begin
StrTmp:='TE: '+Trim(FOverlayInfo.EchoTime);
TextOut(StrLeft,StrTop,StrTmp);
StrTop:=StrTop+StrHeight;
end;
if (ORepTime in FOverlaySet)and(Trim(FOverlayInfo.RepTime)<>'')
and(Trim(FOverlayInfo.Modality)='MR') then
begin
StrTmp:='TR: '+Trim(FOverlayInfo.RepTime);
TextOut(StrLeft,StrTop,StrTmp);
StrTop:=StrTop+StrHeight;
end;
StrTop:=Height-StrHeight-5;
if (OZoom in FOverlaySet) and (Fscale>0) then //缩放比例
begin
strtmp:=Format('Z:%d%%',[round(Fscale*100)]);
StrLeft:=2;
TextOut(StrLeft,StrTop,StrTmp);
end;
end;//end of Canvas
end;
procedure TBitViewer.ShowRule;
Var
StrTmp:string;
StartX,StartY,StartYTmp:integer;
RuleDistance:integer;
LineLen:integer;
i:integer;
begin
with Canvas do
begin
Pen.Color:=RGB(0,255,0);
Moveto(FCenterIntx,0);
LineTo(FCenterIntx,10);
Moveto(FCenterIntx,Height);
LineTo(FCenterIntx,Height-10);
Moveto(0,FCenterIntY);
LineTo(10,FCenterIntY);
Moveto(width,FCenterIntY);
LineTo(width-10,FCenterIntY);
end;
RectAngle(FCenterIntX-2,FCenterIntY-2,FCenterIntX+2,FCenterIntY+2,1,RGB(0,255,0),PsSolid);
{if not (ORule in FOverlaySet) then Exit;
if (FShowImageStatus=ISNormal) then
begin
Font.Color:=RGB(0,255,0);
Pen.Color:=RGB(0,255,0);
end else
if (FShowImageStatus=ISPrint) then
begin
Font.Color:=RGB(255,255,255);
Pen.Color:=RGB(255,255,255);
end;
Font.Size:=FImageFontSize;
Pen.Width:=2;
StrTmp:='A';
if FRuleSize<>'' then
begin
StartX:=(10+TextExtent(StrTmp).CX+4);
StartY:=Height div 4;
RuleDistance:=Height div 20;
MoveTo(StartX,StartY);
LineTo(StartX,StartY+RuleDistance*10);
for i:=0 to 10 do
begin
StartYTmp:=StartY+i*RuleDistance;
if (i Mod 2)=0 then
LineLen:=15
else
LineLen:=8;
MoveTo(StartX,StartYTmp);
LineTo(StartX+LineLen,StartYTmp);
end;
TextOut(10,StartYTmp+5,FRuleSize);
end;
if FLeftOrientation<>'' then
begin
TextOut(10,(Height div 2)-(TExtExtent(StrTmp).CY div 2),FLeftOrientation);
end;
if FTopOrientation<>'' then
begin
TextOut((Width div 2)-(TExtExtent(StrTmp).CX div 2),10,FTOPOrientation);
end;
end;//end of Canvas; }
end;
function TBitViewer.GetImageCanvas:TCanvas;
begin
Result:=Canvas;
end;
function TBitViewer.GetImageCanvasPenColor:TColor;
begin
Result:=Canvas.Pen.Color;
end;
procedure TBitViewer.SetImageCanvasPenColor(Value:TColor);
begin
Canvas.Pen.Color:=Value;
end;
function TBitViewer.GetImageCanvasPenWidth:integer;
begin
Result:=Canvas.Pen.Width;
end;
procedure TBitViewer.SetImageCanvasPenWidth(Value:integer);
begin
Canvas.Pen.Width:=Value;
end;
function TBitViewer.GetImageCanvasPenStyle:TPenStyle;
begin
Result:=Canvas.Pen.Style;
end;
procedure TBitViewer.SetImageCanvasPenStyle(Value:TPenStyle);
begin
Canvas.Pen.Style:=Value;
end;
function TBitViewer.GetImageCanvasBrushStyle:TBrushStyle;
begin
Result:=Canvas.Brush.Style;
end;
procedure TBitViewer.SetImageCanvasBrushStyle(Value:TBrushStyle);
begin
Canvas.Brush.Style:=Value;
end;
// filename property editor, simple
// Register component and filename editor
// I put them on the additional page (where TImage lives) but
// you might put it on Win 95 as it is win 32 API specific.
procedure Register;
begin
//RegisterComponents (LoadStr(srAdditional), [TBitViewer]);
RegisterComponents ('Cool', [TBitViewer]);
end;
end.