unit File2;
{Routines used by NIH Image for printing plus a few additional File Menu routines.}
interface
uses
Memory, QuickDraw, Packages, Menus, Events, Fonts, Scrap, ToolUtils, Resources, Errors, Palettes, Printing, StandardFile, Folders, globals, Utilities, Graphics, Lut, AEinterface;
procedure GetInfo;
procedure DoPageSetup;
procedure Print (ShowDialog: boolean);
procedure SetHalftone;
function OpenMacPaint (fname: str255; vnum: integer): boolean;
procedure TypeMismatch (fname: str255);
procedure SaveAsMacPaint (fname: str255; RefNum: integer);
function GetTextFile (var name: str255; var RefNum: integer): boolean;
procedure InitTextInput (name: str255; RefNum: integer);
procedure GetLineFromText (var rLine: RealLine; var count: integer);
function ImportTextFile (name: str255; RefNum: integer): boolean;
procedure PlotXYZ;
procedure SaveSettings;
procedure ExportAsText (fname: str255; RefNum: integer);
procedure ExportMeasurements (fname: str255; RefNum: integer);
function OpenTiffHeader (f: integer; var DirOffset: LongInt): boolean;
function OpenTiffDirectory (f: integer; DirOffset: LongInt; var TiffInfo: TiffInfoRec; Importing: boolean): boolean;
procedure SaveTiffColorMap (f: integer; ImageDataSize: LongInt);
procedure GetTiffColorMap (f: integer);
function SaveTiffDir (f, slines, sPixelsPerLine: integer; SavingSelection: boolean; ctabSize, ImageDataSize: LongInt): OSErr;
function RoomForFile (fname: str255; RefNum: integer; slines, sPixelsPerLine: integer; SavingSelection: boolean): boolean;
function WriteExtraTiffIFDs (f: integer; ImageDataSize, cTabSize: LongInt): integer;
procedure SaveLUT (fname: str255; RefNum: integer);
procedure SaveColorTable (fname: str255; RefNum: integer);
procedure ExportCoordinates (fname: str255; RefNum: integer);
procedure SaveOutline (fname: str255; RefNum: integer);
procedure OpenOutline (fname: str255; RefNum: integer);
function CheckIO (err: OSerr): integer;
function GetTIFFParameters (name: str255; RefNum: integer; var HasColorMap: boolean): boolean;
procedure GetXUnits (UnitsKind: UnitsType);
procedure GetUnitsKInd (var UnitsKind: UnitsType; var UnitsPerCM: extended);
procedure Swap2Bytes (var i: integer);
implementation
var
gstr: str255;
{$PUSH}
{$D-}
procedure PrintErrCheck;
var
err: integer;
ticks: LongInt;
begin
err := PrError;
if err < 0 then
beep;
end;
procedure DoPageSetup;
var
result: boolean;
begin
if ForceToFront <> noErr then exit(DoPageSetup); { AE - RMD 1/10/95 }
PrOpen;
if PrintRecord = nil then begin
PrintRecord := THPrint(NewHandle(SizeOF(TPrint)));
PrintDefault(PrintRecord);
end;
if PrError = NoErr then begin
result := PrValidate(PrintRecord);
result := PrStlDialog(PrintRecord);
end;
PrClose;
end;
procedure PrintHalftone;
const
PostScriptBegin = 190;
PostScriptEnd = 191;
PostScriptHandle = 192;
TextIsPostScript = 194;
var
HexBufH: handle;
hloc, vloc, HexCount, iheight, iwidth, hstart, vstart: integer;
Height, Width, eofStr, angle, freq: str255;
aLine: LineType;
HexBuf: packed array[0..4200] of char;
err: OSErr;
table: LookupTable;
procedure PutHEX (byt: integer);
var
i, LowByte, HighByte, tmp: integer;
h: char;
begin
if not info^.IdentityFunction then
byt := table[byt];
byt := 255 - byt;
LowByte := byt mod 16;
byt := byt div 16;
HighByte := byt mod 16;
for i := 1 to 2 do begin
if i = 1 then
tmp := HighByte
else
tmp := LowByte;
case tmp of
0:
h := '0';
1:
h := '1';
2:
h := '2';
3:
h := '3';
4:
h := '4';
5:
h := '5';
6:
h := '6';
7:
h := '7';
8:
h := '8';
9:
h := '9';
10:
h := 'a';
11:
h := 'b';
12:
h := 'c';
13:
h := 'd';
14:
h := 'e';
15:
h := 'f';
end;
hexbuf[HexCount] := h;
HexCount := HexCount + 1;
if HexCount mod 80 = 0 then begin
HexBuf[HexCount] := cr;
HexCount := HexCount + 1
end;
end;
end;
begin
with info^ do begin
if not IdentityFunction then
GetLookupTable(table);
MoveTo(-1, -1);
LineTo(-1, -1); {Nothing prints without this dummy dot!}
PicComment(PostScriptBegin, 0, nil); {See Tech Note #91}
PicComment(TextIsPostScript, 0, nil);
NumToString(HalftoneFrequency, freq);
NumToString(HalftoneAngle, angle);
if HalftoneDotFunction then
DrawString(concat(freq, ' ', angle, ' {dup mul exch dup mul add 1 exch sub} setscreen'))
else
DrawString(concat(freq, ' ', angle, ' {pop} setscreen'));
DrawString('0 0 translate');
with RoiRect do begin
iwidth := right - left;
if iwidth > MaxLine then
iwidth := MaxLine;
iheight := bottom - top;
hstart := left;
vstart := top;
end;
NumToString(iwidth, width);
NumToString(iheight, height);
DrawString(concat(width, ' ', height, ' scale'));
DrawString(concat('/PicStr ', width, ' string def'));
DrawString(concat(width, ' ', height, ' 8 [', width, ' 0 0 ', height, ' 0 0]'));
DrawString('{currentfile PicStr readhexstring pop} image');
for vloc := vstart to vstart + iheight - 1 do begin
GetLine(hstart, vloc, iwidth, aline);
HexCount := 0;
for hloc := 0 to iwidth - 1 do
PutHex(aline[hloc]);
HexBuf[HexCount] := cr;
HexCount := HexCount + 1;
err := PtrToHand(@HexBuf, HexBufH, HexCount);
if err <> noErr then
exit(PrintHalftone);
PicComment(PostScriptHandle, HexCount, HexBufH);
DisposeHandle(HexBufH);
Show2Values(vloc - vstart, iheight);
if CommandPeriod then begin
beep;
eofStr := chr(4);
DrawString(eofStr);
exit(PrintHalftone)
end;
end;
end;
end;
procedure PrintTheImage (PageWidth, PageHeight: integer);
var
PrintRect: rect;
Width, Height: integer;
procedure ScaleToFitPage;
var
hscale, vscale, scale: extended;
begin
hscale := PageWidth / width;
vscale := PageHeight / height;
if hscale <= vscale then
scale := hscale
else
scale := vscale;
width := trunc(scale * width);
height := trunc(scale * height);
end;
procedure CenterOnPage;
begin
with PrintRect do begin
left := 0;
top := 0;
if width < PageWidth then
left := (PageWidth - width) div 2;
if height < PageHeight then
top := (Pageheight - height) div 2;
right := left + width;
bottom := top + height;
end;
end;
begin
if isLaserWriter and (not DriverHalftoning) then
PrintHalftone
else
with info^ do begin
LoadLUT(cTable);
hlock(handle(osPort^.portPixMap));
with RoiRect do begin
width := right - left;
height := bottom - top;
end;
if (width > PageWidth) or (height > PageHeight) then
ScaleToFitPage;
CenterOnPage;
if BitAnd(qd.thePort^.portBits.rowBytes, $8000) = $8000 then begin
{Assume driver understands Color QD}
CopyBits(BitMapHandle(osPort^.portPixMap)^^, BitMapHandle(CGrafPtr(qd.thePort)^.PortPixMap)^^, RoiRect, PrintRect, SrcCopy, nil);
end
else
CopyBits(BitMapHandle(osPort^.portPixMap)^^, qd.thePort^.PortBits, RoiRect, PrintRect, SrcCopy, nil);
end;
end;
procedure PrintTextBuffer (PageHeight: integer; var PrintPort: TPPrPort);
const
LineInc = 13;
var
vloc, i, LineCount, CharCount, LinesPerPage, MaxCount: integer;
aLine: str255;
begin
ClipTextInBuffer := false;
LinesPerPage := PageHeight div LineInc;
vloc := LineInc;
LineCount := 0;
CharCount := 0;
TextFont(Monaco);
TextSize(9);
if WhatToPrint = PrintText then
MaxCount := 85
else
MaxCount := 255;
i := 1;
repeat
CharCount := 0;
while (TextBufP^[i] <> cr) and (CharCount < MaxCount) and (i <= TextBufSize) do begin
CharCount := CharCount + 1;
aLine[CharCount] := TextBufP^[i];
i := i + 1;
end;
if TextBufP^[i] = cr then
i := i + 1
else if CharCount = MaxCount then begin
while (aLine[CharCount] <> ' ') and (CharCount > (MaxCount - 15)) do begin
CharCount := CharCount - 1;
i := i - 1;
end;
if TextBufP^[i] = ' ' then
i := i + 1;
end;
aLine[0] := chr(CharCount);
MoveTo(0, vloc);
DrawString(aLine);
vLoc := vLoc + LineInc;
LineCount := LineCount + 1;
if LineCount >= LinesPerPage then begin
LineCount := 0;
if i < TextBufSize then begin
PrClosePage(PrintPort);
PrintErrCheck;
PrOpenPage(PrintPort, nil);
vloc := LineInc
end;
end;
until i > TextBufSize;
end;
procedure DoPrintText (PageHeight: integer; var PrintPort: TPPrPort);
var
ByteCount: LongInt;
begin
if TextInfo <> nil then
with TextInfo^.TextTE^^ do begin
ByteCount := TELength;
BlockMove(hText^, ptr(TextBufP), ByteCount);
TextBufSize := ByteCount;
PrintTextBuffer(PageHeight, PrintPort);
end;
end;
procedure Print (ShowDialog: boolean);
var
err, i, LinesToPrint: Integer;
tPort: GrafPtr;
PrintPort: TPPrPort;
PrintStatusRec: TPrStatus;
prect: rect;
result: boolean;
begin
if WhatToPrint = PrintImage then
SelectAll(false);
if (WhatToPrint = PrintImage) or (WhatToPrint = PrintSelection) then begin
if OpPending then
KillRoi;
with info^.RoiRect do
LinesToPrint := bottom - top;
if not DriverHalftoning then begin
DrawLabels('Line:', 'Total:', '');
Show2Values(0, LinesToPrint);
end;
end;
GetPort(tPort);
PrOpen;
if PrintRecord = nil then begin
PrintRecord := THPrint(NewHandle(SizeOF(TPrint)));
PrintDefault(PrintRecord);
end;
if PrError = NoErr then begin
InitCursor;
result := PrValidate(PrintRecord);
isLaserWriter := BSR(PrintRecord^^.prStl.wDev, 8) = 3;
prect := PrintRecord^^.prInfo.rPage;
if ShowDialog then begin
if ForceToFront <> noErr then result := false; { AE - RMD 1/10/95 }
result := PrJobDialog(PrintRecord)
end
else
result := true;
if not DriverHalftoning then
ShowMessage(CmdPeriodToStop);
ShowWatch;
if result then
for i := 1 to PrintRecord^^.PrJob.icopies do begin
PrintPort := PrOpenDoc(PrintRecord, nil, nil);
PrintErrCheck;
Printing := true;
PrOpenPage(PrintPort, nil);
if PrError = NoErr then
case WhatToPrint of
PrintImage, PrintSelection:
PrintTheImage(prect.right, prect.bottom);
PrintMeasurements: begin
CopyResultsToBuffer(1, mCount, true);
PrintTextBuffer(prect.Bottom, PrintPort);
UnsavedResults := false;
end;
PrintPlot:
DrawPlot;
PrintHistogram:
DrawHistogram;
PrintText:
DoPrintText(prect.Bottom, PrintPort);
end;
Printing := false;
PrClosePage(PrintPort);
PrintErrCheck;
PrCloseDoc(PrintPort);
PrintErrCheck;
if PrintRecord^^.prJob.bJDocLoop = bSpoolLoop then
PrPicFile(PrintRecord, nil, nil, nil, PrintStatusRec);
end;
end;
PrClose;
SetPort(tPort);
if WhatToPrint = PrintImage then
KillRoi;
ShowMessage(' ');
end;
procedure SetHalftone;
const
FrequencyID = 8;
AngleID = 10;
DotID = 4;
LineID = 5;
CustomID = 13;
var
mylog: DialogPtr;
item, i, ignore, SaveFrequency, SaveAngle: integer;
SaveFunction, SaveCustom: boolean;
str: str255;
begin
if ForceToFront <> noErr then exit(SetHalftone); { AE - RMD 1/10/95 }
SaveFrequency := HalftoneFrequency;
SaveAngle := HalftoneAngle;
SaveFunction := HalftoneDotFunction;
SaveCustom := DriverHalftoning;
mylog := GetNewDialog(30, nil, pointer(-1));
SetDNum(MyLog, FrequencyID, HalftoneFrequency);
SelectdialogItemText(MyLog, FrequencyID, 0, 32767);
SetDNum(MyLog, AngleID, HalftoneAngle);
SetDlogItem(mylog, CustomID, ord(not DriverHalftoning));
OutlineButton(MyLog, ok, 16);
if HalftoneDotFunction then
SetDlogItem(mylog, DotID, 1)
else
SetDlogItem(mylog, LineID, 1);
repeat
ModalDialog(nil, item);
if item = FrequencyID then begin
HalftoneFrequency := GetDNum(MyLog, FrequencyID);
DriverHalftoning := false;
SetDlogItem(mylog, CustomID, ord(not DriverHalftoning));
end;
if item = AngleID then begin
HalftoneAngle := GetDNum(MyLog, AngleID);
if (HalftoneAngle < 0) or (HalftoneAngle > 180) then begin
beep;
HalftoneAngle := SaveAngle;
end;
DriverHalftoning := false;
SetDlogItem(mylog, CustomID, ord(not DriverHalftoning));
end;
if (item >= DotID) and (item <= LineID) then begin
for i := DotID to LineID do
SetDlogItem(mylog, i, 0);
SetDlogItem(mylog, item, 1);
HalftoneDotFunction := item = DotID;
DriverHalftoning := false;
SetDlogItem(mylog, CustomID, ord(not DriverHalftoning));
end;
if item = CustomID then begin
DriverHalftoning := not DriverHalftoning;
SetDlogItem(mylog, CustomID, ord(not DriverHalftoning));
end;
until (item = ok) or (item = cancel);
DisposeDialog(mylog);
if item = cancel then begin
HalftoneFrequency := SaveFrequency;
HalftoneAngle := SaveAngle;
HalftoneDotFunction := SaveFunction;
DriverHalftoning := SaveCustom;
end;
end;
{$POP}
procedure GetFileInfo (name: str255; vnum: integer; var DateCreated, LastModified: str255);
var
FileParmBlock: CInfoPBRec;
theErr: OSErr;
DateVar, TimeVar: str255;
Secs: LongInt;
begin
DateCreated := '';
with FileParmBlock do begin
ioCompletion := nil;
ioNamePtr := @name;
ioVRefNum := vnum;
ioFVersNum := 0;
ioFDirIndex := 0;
theErr := PBGetCatInfoSync(@FileParmBlock); {ppc-bug}
if theErr = NoErr then begin
Secs := ioFlCrDat;
IUDateString(Secs, abbrevDate, DateVar);
IUTimeString(Secs, true, TimeVar);
DateCreated := concat(DateVar, ' ', TimeVar);
Secs := ioFlMDDat;
IUDateString(Secs, abbrevDate, DateVar);
IUTimeString(Secs, true, TimeVar);
LastModified := concat(DateVar, ' ', TimeVar);
end;
end;
end;
procedure GetVolumnInfo (vnum: integer; var VolumnName: str255; var FreeSpace: LongInt);
var
theErr: OSErr;
str: str255;
VolParmBlock: ParamBlockRec;
begin
VolumnName := '';
with VolParmBlock do begin
str := '';
ioVRefNum := vnum;
ioNamePtr := @str;
ioCompletion := nil;
ioVolIndex := -1;
theErr := PBGetVInfoSync(@VolParmBlock); {ppc-bug}
VolumnName := ioNamePtr^;
FreeSpace := ioVAlBlkSiz * ioVFrBlk;
end;
end;
function RoomForFile (fname: str255; RefNum: integer; slines, sPixelsPerLine: integer; SavingSelection: boolean): boolean;
var
err: OSErr;
f: integer;
VolumnName: str255;
FreeSpace, ExistingFileSize, NeededSize: LongInt;
begin
with info^ do begin
ExistingFileSize := 0;
RoomForFile := true;
err := fsopen(fname, RefNum, f);
if err = 0 then begin
err := GetEOF(f, ExistingFileSize);
err := fsClose(f);
end;
if ExistingFileSize <> 0 then begin
if SavingSelection then begin
NeededSize := sLines;
NeededSize := NeededSize * sPixelsPerLine
end
else
NeededSize := ImageSize;
if StackInfo <> nil then
with StackInfo^ do
NeededSize := NeededSize * nSlices + nSlices * SizeOf(StackIFDType);
GetVolumnInfo(RefNum, VolumnName, FreeSpace);
if (NeededSize - ExistingFileSize + 8192) > FreeSpace then begin
PutError('There is not enough free space on this disk to save this image.');
RoomForFile := false;
end;
end;
end;
end;
procedure GetInfo;
var
name, str, DateCreated, LastModified, VolumnName, str2: str255;
hloc, vloc, InfoWidth, InfoHeight: integer;
SaveRoiShowing: boolean;
FreeSpace, DataSize: LongInt;
SaveForeIndex, SaveBackIndex: integer;
ImageInfo, InfoWindowInfo: InfoPtr;
x1, y1, x2, y2, ulength, clength: extended;
SaveGDevice: GDHandle;
procedure NewLine;
begin
vloc := vloc + 13;
MoveTo(hloc, vloc);
end;
procedure NewParagraph;
begin
vloc := vloc + 18;
MoveTo(hloc, vloc);
end;
begin
InfoWidth := 260;
InfoHeight := 260;
with info^ do begin
if RoiShowing then
InfoHeight := InfoHeight + 50;
if RoiShowing and (RoiType = LineRoi) then
InfoHeight := InfoHeight + 20;
if vref <> 0 then
InfoHeight := InfoHeight + 60;
name := concat('Info About ', title);
SaveRoiShowing := RoiShowing;
end;
SaveForeIndex := ForegroundIndex;
SaveBackIndex := BackgroundIndex;
SetForegroundColor(BlackIndex);
SetBackgroundColor(WhiteIndex);
ImageInfo := info;
if NewPicWindow(name, InfoWidth, InfoHeight) then
with ImageInfo^ do begin
InfoWindowInfo := Info;
SaveGDevice := GetGDevice;
SetGDevice(osGDevice);
SetPort(GrafPtr(info^.osPort));
TextFont(Geneva);
TextSize(9);
hloc := 15;
vloc := 10;
NewLine;
DrawBString('Name: ');
DrawString(title);
NewParagraph;
DrawBString('Width: ');
DrawXDimension(PixelsPerLine, 0);
NewLine;
DrawBString('Height: ');
DrawYDimension(nlines, 0);
if StackInfo <> nil then begin
NewLine;
DrawBString('Depth: ');
DrawLong(StackInfo^.nSlices);
end;
NewLine;
DrawBString('Size: ');
if StackInfo <> nil then
DataSize := PixMapSize * StackInfo^.nSlices
else
DataSize := PixMapSize;
DrawLong((DataSize + 511) div 1024);
DrawString('K');
NewParagraph;
GetFileInfo(title, vref, DateCreated, LastModified); {DateCreated:='';}
if DateCreated <> '' then begin
DrawBString('Creation Date: ');
DrawString(DateCreated);
NewLine;
DrawBString('Last Modified: ');
DrawString(LastModified);
NewLine;
end;
if fileVersion > 0 then begin
DrawBString('Version: ');
DrawString('Created by NIH Image ');
DrawReal(fileVersion / 100.0, 1, 2);
NewParagraph;
end;
DrawBString('Type: ');
if StackInfo <> nil then case StackInfo^.StackType of
VolumeStack, MovieStack:
str := concat('Stack (', long2str(StackInfo^.nSlices), ' slices)');
rgbStack:
str := 'RGB color stack';
else
;
end else begin
case PictureType of
NewPicture:
str := 'New';
Normal:
str := 'Normal';
PictFile:
str := 'PICT';
TiffFile:
str := 'TIFF';
Leftover:
str := 'Left Over';
Imported: begin
if DataType = EightBits then
str := 'Imported 8-bit image'
else
str := 'Imported 16-bit image';
end;
FrameGrabberType:
str := 'Camera';
BlankField:
str := 'Blank Field';
otherwise
;
end;
if BinaryPic then
str := concat(str, ' (Binary)');
end;
DrawString(str);
if StackInfo <> nil then
with StackInfo^ do
if SliceSpacing <> 0.0 then begin
NewLine;
DrawBString('Slice Spacing: ');
if SpatiallyCalibrated then
DrawString(StringOf(SliceSpacing / xScale:1:2, ' ', xunit, ' (', SliceSpacing:1:2, ' pixels)'))
else
DrawString(StringOf(SliceSpacing:1:2, ' pixels'));
end;
NewLine;
DrawBString('Lookup Table: ');
case LutMode of
PseudoColor:
str := concat('Pseudocolor (', long2str(ncolors), ', ', long2str(ColorStart), '-', long2str(ColorEnd), ')');
GrayScale:
str := concat('Grayscale (', long2str(ncolors), ', ', long2str(ColorStart), '-', long2str(ColorEnd), ')');
ColorLut:
str := 'Color';
CustomGrayscale:
str := 'Custom Grayscale';
otherwise
end;
DrawString(str);
NewLine;
DrawBString('Magnification: ');
if ScaleToFitWindow then begin
DrawReal(magnification, 1, 2);
DrawString(' (Scale to Window Mode)')
end
else begin
DrawReal(magnification, 1, 0);
DrawString(':1')
end;
NewLine;
DrawBString('Scale: ');
if SpatiallyCalibrated then begin
DrawReal(xScale, 1, 3);
DrawString(' pixels per ');
DrawString(xUnit);
if PixelAspectRatio <> 1.0 then begin
NewLine;
DrawBString('Pixel Aspect Ratio: ');
DrawReal(PixelAspectRatio, 1, 4);
end;
end
else
DrawString('None');
if fit <> uncalibrated then begin
NewLine;
DrawBString('Unit of Measure: ');
if UnitOfMEasure = '' then
DrawString('None')
else
DrawString(UnitOfMeasure)
end;
NewParagraph;
DrawBString('Free RAM: ');
DrawLong(FreeMem div 1024);
DrawString('K');
NewLine;
DrawBString('Largest Free Block: ');
DrawLong(MaxBlock div 1024);
DrawString('K');
if FrameGrabber <> NoFrameGrabber then begin
NewLine;
DrawBString('Frame Grabber: ');
case FrameGrabber of
QuickCapture: begin
if fgWidth = 768 then
DrawString('50Hz')
else
DrawString('60Hz');
DrawString(' Data Translation QuickCapture');
end;
ScionLG3: begin
if fgWidth = 768 then
DrawString('50Hz')
else
DrawString('60Hz');
DrawString(' Scion LG-3 (');
DrawLong(MaxLG3Frames div 2);
DrawString(' MB)');
end;
ScionAG5: begin
if fgWidth = 768 then
DrawString('50Hz')
else
DrawString('60Hz');
DrawString(' Scion AG-5');
end;
ScionVG5f: begin
if fgWidth = 768 then
DrawString('50Hz')
else
DrawString('60Hz');
DrawString(' Scion VG-5');
end
end;
end;
NewParagraph;
if RoiType <> NoRoi then begin
DrawBString('Selection Type: ');
case RoiType of
PolygonRoi:
DrawString('Polygon');
FreehandRoi:
DrawString('Freehand');
RectRoi:
DrawString('Rectangle');
OvalRoi:
DrawString('Oval');
LineRoi:
DrawString('Straight Line');
FreeLineRoi:
DrawString('Freehand Line');
SegLineRoi:
DrawString('Segmented Line');
end;
NewLine;
case RoiType of
PolygonRoi, FreehandRoi, RectRoi, OvalRoi:
with RoiRect do begin
DrawBString(' Left: ');
DrawXDimension(left, 0);
NewLine;
DrawBString(' Top: ');
if InvertYCoordinates then
DrawYDimension(PicRect.bottom - top - 1, 0)
else
DrawYDimension(top, 0);
NewLine;
DrawBString(' Width: ');
DrawXDimension(right - left, 0);
NewLine;
DrawBString(' Height: ');
DrawYDimension(bottom - top, 0);
end;
LineRoi: begin
info := ImageInfo;
GetLengthOrPerimeter(ulength, clength);
GetLoi(x1, y1, x2, y2);
Info := InfoWindowInfo;
DrawBString(' Length: ');
if SpatiallyCalibrated then begin
DrawReal(cLength, 1, 2);
DrawString(xUnit);
end
else
DrawReal(uLength, 1, 2);
NewLine;
DrawBString(' Angle: ');
DrawReal(LAngle, 1, 2);
DrawString('Ą');
NewLine;
DrawBString(' X1: ');
DrawXDimension(x1, 2);
NewLine;
DrawBString(' Y1: ');
if InvertYCoordinates then
DrawYDimension(PicRect.bottom - y1 - 1, 2)
else
DrawYDimension(y1, 2);
NewLine;
DrawBString(' X2: ');
DrawXDimension(x2, 2);
NewLine;
DrawBString(' Y2: ');
if InvertYCoordinates then
DrawYDimension(PicRect.bottom - y2 - 1, 2)
else
DrawYDimension(y2, 2);
end;
FreeLineRoi, SegLineRoi: begin
info := ImageInfo;
GetLengthOrPerimeter(ulength, clength);
Info := InfoWindowInfo;
DrawBString(' Length: ');
if SpatiallyCalibrated then begin
DrawReal(cLength, 1, 2);
DrawString(xUnit);
end
else
DrawReal(uLength, 1, 2);
NewLine;
end;
otherwise
end; {case}
end
else
DrawBString('No Selection');
SetGDevice(SaveGDevice);
end; {with ImageInfo^}
SetForegroundColor(SaveForeIndex);
SetBackgroundColor(SaveBackIndex);
end;
function CheckIO (err: OSerr): integer;
var
ErrStr, Message: str255;
ignore: integer;
SaveGDevice: GDHandle;
begin
if err <> 0 then begin
case err of
-34: Message := 'Disk Full';
-35: Message := 'No such volume';
-36: Message := 'I/O Error';
-39: Message := 'End of file error';
-49: Message := 'File in Use';
-61: Message := 'Write Permission Error';
-120: Message := 'Folder not found'
otherwise Message := '';
end;
SaveGDevice := GetGDevice;
SetGDevice(GetMainDevice);
NumToString(err, ErrStr);
ParamText(Message, ErrStr, '', '');
InitCursor;
ignore := alert(IOErrorID, nil);
SetGDevice(SaveGDevice);
AbortMacro;
end;
CheckIO := err;
end;
function OpenMacPaint (fname: str255; vnum: integer): boolean;
const
MaxUnPackedSize = 51840; {Max MacPaint size in bytes=720 lines * 72 bytes/line }
type
mpLine = array[1..18] of LongInt;
mpArrayT = array[1..720] of mpLine;
mpArrayP = ^mpArrayT;
var
i, f, ScanLine, LastLine, LastWord, LastColumn: integer;
err: osErr;
srcSize: LongInt;
srcPtr, dstPtr, src, dst: ptr;
theBitMap: BitMap;
mpArray: mpArrayP;
BlankLine, BlankColumn: boolean;
frect: rect;
SaveGDevice: GDHandle;
procedure abort;
begin
beep;
if srcPtr <> nil then
DisposePtr(srcPtr);
if dstPtr <> nil then
DisposePtr(dstPtr);
{exit(OpenMacPaint);} {ppc-bug}
end;
begin
OpenMacPaint := false;
err := fsOpen(fname, vnum, f);
if CheckIO(err) <> noErr then
exit(OpenMacPaint);
err := GetEOF(f, srcSize);
srcSize := srcSize - 512;
srcPtr := NewPtr(srcSize);
if srcPtr = nil then begin
abort;
exit(OpenMacPaint);
end;
err := SetFPos(f, fsFromStart, 512);
err := fsRead(f, srcSize, srcPtr);
if CheckIO(err) <> noErr then
exit(OpenMacPaint);
err := fsClose(f);
dstPtr := NewPtrClear(MaxUnPackedSize);
if dstPtr = nil then begin
abort;
exit(OpenMacPaint);
end;
src := srcPtr;
dst := dstPtr;
for scanLine := 1 to 720 do
UnPackBits(src, dst, 72); {bumps both ptrs}
DisposePtr(srcPtr);
mpArray := mpArrayP(dstPtr);
LastLine := 720;
BlankLine := true;
repeat
for i := 1 to 18 do
blankLine := BlankLine and (mpArray^[LastLine, i] = 0);
if BlankLine then
LastLine := LastLine - 1;
until (not BlankLine) or (LastLine = 1);
LastWord := 18;
BlankColumn := true;
repeat
for i := 1 to LastLine do
blankColumn := BlankColumn and (mpArray^[i, LastWord] = 0);
if BlankColumn then
LastWord := LastWord - 1;
until (not BlankColumn) or (LastWord = 1);
LastColumn := LastWord * 32;
LastColumn := LastColumn + 8;
if LastColumn > 576 then
LastColumn := 576;
LastLine := LastLine + 8;
if LastLine > 720 then
LastLine := 720;
SetRect(frect, 0, 0, LastColumn, LastLine);
with theBitMap do begin
baseAddr := dstPtr;
rowBytes := 72;
bounds := frect;
end;
if not NewPicWindow(fname, LastColumn, LastLine) then begin
abort;
exit(OpenMacPaint);
end;
SaveGDevice := GetGDevice;
SetGDevice(osGDevice);
SetForegroundColor(BlackIndex);
SetBackgroundColor(WhiteIndex);
with info^ do begin
CopyBits(theBitMap, BitMapHandle(osPort^.PortPixMap)^^, frect, frect, SrcCopy, nil);
DisposePtr(dstPtr);
PictureType := imported;
BinaryPic := true;
SetGDevice(SaveGDevice);
if PixMapSize > UndoBufSize then
PutWarning;
end;
OpenMacPaint := true;
end;
procedure TypeMismatch (fname: str255);
begin
PutError(concat('The file "', fname, '" is a different type, and therefore cannot be replaced'));
end;
procedure SaveAsMacPaint (fname: str255; RefNum: integer);
const
MaxFileSize = 53072; { maximum MacPaint file size. }
var
TheInfo: FInfo;
dstPtr, srcPtr, mpBufPtr: Ptr;
i, f, scanLine, err, width, height: integer;
dstBuffer: array[1..128] of LongInt;
size, dstSize: LongInt;
theBitMap: BitMap;
mprect, srect, drect: rect;
procedure abort;
begin
beep;
if mpBufPtr <> nil then
DisposePtr(mpBufPtr);
if f <> -1 then
err := fsclose(f);
{exit(SaveAsMacPaint);} {ppc-bug}
end;
begin
f := -1;
err := GetFInfo(fname, RefNum, TheInfo);
case err of
NoErr:
with TheInfo do begin
if fdType <> 'PNTG' then begin
TypeMismatch(fname);
exit(SaveAsMacPaint)
end;
end;
FNFerr: begin
err := create(fname, RefNum, 'MPNT', 'PNTG');
if CheckIO(err) <> 0 then
exit(SaveAsMacPaint);
end;
otherwise
if CheckIO(err) <> 0 then
exit(SaveAsMacPaint);
end;
mpBufPtr := NewPtrClear(MaxFileSize);
if mpBufPtr = nil then begin
abort;
exit(SaveAsMacPaint);
end;
ShowWatch;
SetRect(mprect, 0, 0, 576, 720);
with theBitMap do begin
baseAddr := mpBufPtr;
rowBytes := 72;
bounds := mprect;
end;
with info^ do begin
if roiShowing then
srect := RoiRect
else
srect := PicRect;
with srect do begin
width := right - left;
height := bottom - top;
if width > 576 then
width := 576;
if height > 720 then
height := 720;
right := left + width;
bottom := top + height;
end;
SetRect(drect, 0, 0, width, height);
CopyBits(BitMapHandle(osPort^.PortPixMap)^^, theBitMap, srect, drect, srcCopy, nil);
end;
err := fsOpen(fname, RefNum, f);
if CheckIO(err) <> noErr then begin
abort;
exit(SaveAsMacPaint);
end;
for I := 1 to 128 do
dstBuffer[I] := 0;
Size := 512;
err := FSWrite(f, Size, @dstBuffer);
if CheckIO(err) <> noErr then begin
abort;
exit(SaveAsMacPaint);
end;
srcPtr := theBitMap.baseAddr;
for scanLine := 1 to 720 do begin
dstPtr := @dstBuffer; { reset the pointer to bottom }
PackBits(srcPtr, dstPtr, 72); { bumps both ptrs}
dstSize := ord(dstPtr) - ord(@dstBuffer);{calc packed size}
err := fsWrite(f, dstSize, @dstBuffer);
if CheckIO(err) <> noErr then begin
abort;
exit(SaveAsMacPaint);
end;
end;
err := fsclose(f);
DisposePtr(mpBufPtr);
if not info^.RoiShowing then
info^.changes := false;
end;
function GetTextFile (var name: str255; var RefNum: integer): boolean;
var
where: Point;
typeList: SFTypeList;
reply: SFReply;
err: OSErr;
pBlock: WDPBRec;
begin
if ForceToFront <> noErr then begin { AE - RMD 1/10/95 }
GetTextFile := false;
exit(GetTextFile);
end;
where.v := 120;
where.h := 120;
typeList[0] := 'TEXT';
SFGetFile(Where, '', nil, 1, @typeList, nil, reply);
if reply.good then
with reply do begin
name := fname;
RefNum := vRefNum;
GetTextFile := true;
end
else
GetTextFile := false;
end;
procedure GetBuffer;
var
err: OSErr;
count, FilePos: LongInt;
begin
count := MaxTextBufSize;
err := fsread(Textf, count, ptr(TextBufP));
TextBufSize := count;
err := GetFPos(Textf, FilePos);
if FilePos = TextFileSize then begin
TextBufSize := TextBufSize + 1;
if TextBufSize > MaxTextBufSize then
TextBufSize := MaxTextBufSize;
TextBufP^[TextBufSize] := eofChr;
err := fsclose(Textf);
end;
TextIndex := 1;
end;
function GetByte: char;
begin
GetByte := TextBufP^[TextIndex];
TextIndex := TextIndex + 1;
if TextIndex > MaxTextBufSize then
GetBuffer;
end;
function GetNumber: extended;
var
c: char;
str: str255;
begin
repeat
c := GetByte;
if c = tab then begin
GetNumber := 0.0; {Assume 0 zero for missing value.}
exit(GetNumber);
end;
if (c = cr) or (c = eofChr) then begin
TextEol := true;
TextEof := c = eofChr;
GetNumber := NoValue;
exit(GetNumber);
end;
until c in ['0'..'9', '-', '.'];
Str := '';
while c in ['0'..'9', '+', '-', '.', 'e', 'E'] do begin
Str := concat(str, c);
c := GetByte;
if (c = cr) or (c = eofChr) then begin
TextEol := true;
TextEof := c = eofChr;
end;
end;
GetNumber := StringToReal(str);
end;
procedure GetLineFromText (var rLine: RealLine; var count: integer);
var
n: extended;
begin
count := 0;
if TextEof then
exit(GetLineFromText);
repeat
n := GetNumber;
if n <> NoValue then begin
count := count + 1;
rLine[count] := n;
end;
until TextEol or (count = MaxLine);
TextEol := false;
end;
procedure InitTextInput (name: str255; RefNum: integer);
var
err: OSErr;
begin
err := FSOpen(name, RefNum, Textf);
err := GetEof(Textf, TextFileSize);
err := SetFPos(Textf, fsFromStart, 0);
ShowWatch;
if WhatsOnClip = TextOnClip then
WhatsOnClip := NothingOnClip;
GetBuffer;
TextEol := false;
TextEof := false;
end;
function ImportTextFile (name: str255; RefNum: integer): boolean;
var
nRows, nColumns, count, i, vloc, BlankPixel, nPixelsPerLine: integer;
rLine: RealLine;
pvalue: extended;
min, max, ScaleFactor, DefaultValue, tvalue: extended;
err: OSErr;
line, BlankLine: LineType;
TheInfo: FInfo;
noScaling:boolean;
begin
ImportTextFile := false;
err := GetFInfo(name, RefNum, TheInfo);
if TheInfo.fdType <> 'TEXT' then begin
PutError('File is not of type ''TEXT''.');
exit(ImportTextFile);
end;
InitTextInput(name, RefNum);
nRows := 0;
nColumns := 0;
max := -10e-10;
min := 10e10;
ShowMessage(concat('First pass used to find ', crStr, 'width, height,min, and max.', crStr, crStr, CmdPeriodToStop));
DrawLabels('Line:', '', '');
while not TextEof do begin
GetLineFromText(rLine, count);
if not (TextEof and (count = 0)) then
nRows := nRows + 1;
if count > nColumns then
nColumns := count;
for i := 1 to count do begin
pvalue := rLine[i];
if pvalue > max then
max := pvalue;
if pvalue < min then
min := pvalue;
end;
if nRows mod 10 = 0 then begin
Show1Value(nRows, NoValue);
ShowAnimatedWatch;
if CommandPeriod then begin
beep;
err := fsclose(Textf);
Exit(ImportTextFile);
end;
end;
end;
ShowMessage(concat('rows= ', long2str(nRows), crStr, 'columns= ', long2str(ncolumns), crStr, 'min= ', long2str(round(min)), crStr, 'max= ', long2str(round(max))));
if nColumns > MaxLine then begin
PutError(concat('More than ',long2str(MaxLine),' pixels per line.'));
Exit(ImportTextFile);
end;
nPixelsPerLine := nColumns;
if NewPicWindow(name, nPixelsPerLine, nrows) then
with info^ do begin
if (not ImportAutoScale) and (max > min) then begin
min := ImportMin;
max := ImportMax;
end;
ScaleFactor := 253.0 / (max - min);
InitTextInput(name, RefNum);
vloc := 0;
DefaultValue := 0.0;
if DefaultValue < min then
DefaultValue := min;
if DefaultValue > max then
DefaultValue := max;
BlankPixel := round((DefaultValue - min) * ScaleFactor + 1);
for i := 0 to nColumns - 1 do
BlankLine[i] := BlankPixel;
NoScaling:=not ImportAutoScale and ((min=0) and (max=255));
DrawLabels('Line:', 'Total:', '');
while not TextEof do begin
GetLineFromText(rLine, count);
if not (TextEof and (count = 0)) then begin
line := BlankLine;
if ImportAutoScale then {Map values into the range 1-254}
for i := 1 to count do
line[i - 1] := round((rLine[i] - min) * ScaleFactor + 1)
else
for i := 1 to count do begin
tvalue := rLine[i];
if tvalue < min then
tvalue := min;
if tvalue > max then
tvalue := max;
if noScaling
then line[i - 1]:=round(tvalue)
else line[i - 1] := round((tvalue - min) * ScaleFactor + 1);
end;
PutLine(0, vloc, PixelsPerLine, line);
vloc := vloc + 1;
end;
if vloc mod 10 = 0 then begin
Show2Values(vloc, nRows);
ShowAnimatedWatch;
if CommandPeriod then begin
beep;
err := fsclose(Textf);
Exit(ImportTextFile);
end;
end;
end;
if noScaling then
ImportCalibrate:=false
else begin
fit := StraightLine;
nCoefficients := 2;
coefficient[2] := (max - min) / 253.0;
coefficient[1] := min - coefficient[2];
nKnownValues := 0;
UpdateTitleBar;
if macro then
GenerateValues;
ZeroClip := false;
end;
changes := true;
PictureType := imported;
end; {with}
ImportTextFile := true;
end;
procedure PlotXYZ;
{Reads X-Y coordinate pairs and optional intensiy(Z) values from a}
{two or three column tab-delimited text file and plots them in the current window.}
var
fname, str: str255;
RefNum, i, nColumns, nValues, index, wheight: integer;
rLine: RealLine;
begin
RefNum := 0;
if not GetTextFile(fname, RefNum) then
exit(PlotXYZ);
InitTextInput(fname, RefNum);
GetLineFromText(rLine, nValues);
nColumns := nValues;
if not ((nColumns = 2) or (nColumns = 3)) then begin
PutError('File must have two or three columns.');
exit(PlotXYZ);
end;
wheight := info^.nLines;
index := ForegroundIndex;
repeat
if nColumns = 3 then begin
index := round(rLine[3]);
if index > 255 then
index := 255;
if index < 0 then
index := 0;
end;
PutPixel(round(rLine[1]), wheight - round(rLine[2] + 1), index);
GetLineFromText(rLine, nValues);
until nValues = 0;
InitCursor;
end;
procedure SaveSettings;
var
TheInfo: FInfo;
ByteCount: LongInt;
f, i: integer;
err: OSErr;
settings: SettingsType;
PrefsVRef: integer;
PrefsDirID: LongInt;
PrefsSpec: FSSpec;
PrefsError:boolean;
begin
with settings, info^ do begin
sID := 'IMAG';
sVersion := version;
sForegroundIndex := ForegroundIndex;
sBackgroundIndex := BackgroundIndex;
sBrushHeight := BrushHeight;
sBrushWidth := BrushWidth;
sSprayCanDiameter := SprayCanDiameter;
sLUTMode := LUTMode;
sOldColorStart := 30;
sOldColorWidth := 10;
sCurrentFontID := CurrentFontID;
sCurrentStyle := CurrentStyle;
sCurrentSize := CurrentSize;
sTextJust := TextJust;
sTextBack := TextBack;
sNExtraColors := nExtraColors;
sExtraColors := ExtraColors;
sInvertVideo := InvertVideo;
sMeasurements := Measurements;
sInvertPlots := InvertPlots;
sAutoScalePlots := AutoScalePlots;
sLinePlot := LinePlot;
sDrawPlotLabels := DrawPlotLabels;
for i := 1 to 12 do
sUnused1[i] := 0;
sFixedSizePlot := FixedSizePlot;
sProfilePlotWidth := ProfilePlotWidth;
sProfilePlotHeight := ProfilePlotHeight;
sFramesToAverage := FramesToAverage;
sNewPicWidth := NewPicWidth;
sNewPicHeight := NewPicHeight;
sBufferSize := BufferSize;
sMaxScionWidth := MaxScionWidth;
sThresholdToForeground := ThresholdToForeground;
sNonThresholdToBackground := NonThresholdToBackground;
sVideoChannel := VideoChannel;
sWhatToImport := WhatToImport;
sImportCustomWidth := ImportCustomWidth;
sImportCustomHeight := ImportCustomHeight;
sImportCustomOffset := ImportCustomOffset;
sWandAutoMeasure := WandAutoMeasure;
sWandAdjustAreas := WandAdjustAreas;
sBinaryIterations := BinaryIterations;
sScaleArithmetic := ScaleArithmetic;
sInvertPixelValues := InvertPixelValues;
sInvertYCoordinates := InvertYCoordinates;
sFieldWidth := FieldWidth;
sPrecision := precision;
sMinParticleSize := MinParticleSize;
sMaxParticleSize := MaxParticleSize;
sIgnoreParticlesTouchingEdge := IgnoreParticlesTouchingEdge;
sLabelParticles := LabelParticles;
sOutlineParticles := OutlineParticles;
sIncludeHoles := IncludeHoles;
sOscillatingMovies := OscillatingMovies;
sDriverHalftoning := DriverHalftoning;
sMaxMeasurements := MaxMeasurements;
sImportCustomDepth := ImportCustomDepth;
sImportSwapBytes := ImportSwapBytes;
sImportCalibrate := ImportCalibrate;
sImportAutoscale := ImportAutoscale;
for i := 1 to 12 do
sUnused2[i] := 0;
sShowHeadings := ShowHeadings;
sDefaultVRefNum := 0;
sDefaultDirID := 0;
sKernelsVRefNum := 0;
sKernelsDirID := 0;
{***}
sProfilePlotMin := ProfilePlotMin;
sProfilePlotMax := ProfilePlotMax;
sImportMin := ImportMin;
sImportMax := ImportMax;
sHighlightPixels := HighlightSaturatedPixels;
{***}
sBallRadius := BallRadius;
sFasterBackgroundSubtraction := FasterBackgroundSubtraction;
sScaleConvolutions := ScaleConvolutions;
{V1.42}
sBinaryCount := BinaryCount;
sColorTable := ColorTable;
sColorStart := ColorStart;
sColorEnd := ColorEnd;
sInvertedTable := InvertedColorTable;
{V1.44}
sHalftoneFrequency := HalftoneFrequency;
sHalftoneAngle := HalftoneAngle;
sHalftoneDotFunction := HalftoneDotFunction;
sDacLow := DacLow;
sDacHigh := DacHigh;
sSyncMode := SyncMode;
sSwitchLUTOnSuspend := SwitchLUTOnSuspend;
sVideoRateAveraging := VideoRateAveraging;
sImportInvert := ImportInvert;
sTextCreator := TextCreator;
sMathSubGain:=MathSubGain;
sMathSubOffset:=round(MathSubOffset);
for i := 1 to 10 do
sUnused[i] := 0;
end; {with}
if System7 then begin
{Save in Preferences folder}
PrefsError:=true;
err:=FindFolder(kOnSystemDisk, kPreferencesFolderType,
kDontCreateFolder, PrefsVRef, PrefsDirID);
if err=noErr then
err:=FSMakeFSSpec(PrefsVRef, PrefsDirID, PrefsName, PrefsSpec);
if err=noErr
then err:=FSpDelete(PrefsSpec);
if (err=noErr) or (err=fnfErr) then begin
err:=FSpCreate(PrefsSpec, 'Imag', 'PREF', smSystemScript);
if err=noErr then
err:=FSpOpenDF(PrefsSpec, fsCurPerm, f);
if err=noErr then
PrefsError:=false;
end;
if PrefsError then begin
PutError('Error saving settings file');
exit(SaveSettings);
end;
end else begin
{Save in System folder}
err := GetFInfo(PrefsName, SystemRefNum, TheInfo);
if err = FNFerr then begin
err := create(PrefsName, SystemRefNum, 'Imag', 'PREF');
if CheckIO(err) <> 0 then
exit(SaveSettings);
end;
err := fsopen(PrefsName, SystemRefNum, f);
end;
if CheckIO(err) <> 0 then
exit(SaveSettings);
err := SetFPos(f, FSFromStart, 0);
ByteCount := SizeOf(settings);
err := fswrite(f, ByteCount, @settings);
if CheckIO(err) <> 0 then begin
err := fsclose(f);
exit(SaveSettings)
end;
err := SetEof(f, ByteCount);
err := fsclose(f);
err := FlushVol(nil, SystemRefNum);
end;
procedure ExportAsText (fname: str255; RefNum: integer);
var
err, f, width, hloc, vloc: integer;
TheInfo: FInfo;
ByteCount, FileSize: LongInt;
AutoSelectAll: boolean;
tLine: LineType;
begin
if info = NoInfo then
exit(ExportAsText);
err := GetFInfo(fname, RefNum, TheInfo);
case err of
NoErr:
if TheInfo.fdType <> 'TEXT' then begin
TypeMismatch(fname);
exit(ExportAsText)
end;
FNFerr: begin
err := create(fname, RefNum, TextCreator, 'TEXT');
if CheckIO(err) <> 0 then
exit(ExportAsText);
end;
otherwise
if CheckIO(err) <> 0 then
exit(ExportAsText)
end;
ShowWatch;
err := fsopen(fname, RefNum, f);
if CheckIO(err) <> 0 then
exit(ExportAsText);
AutoSelectAll := not info^.RoiShowing;
if AutoSelectAll then
SelectAll(true);
if TooWide then
exit(ExportAsText);
FileSize := 0;
with info^.RoiRect do begin
width := right - left;
for vloc := top to bottom - 1 do begin
GetLine(left, vloc, width, tLine);
TextBufSize := 0;
for hloc := 0 to width - 1 do begin
PutLong(tLine[hloc], 0);
if hloc <> (width - 1) then
PutTab;
end;
PutChar(cr);
ByteCount := TextBufSize;
err := fswrite(f, ByteCount, ptr(TextBufP));
FIleSize := FileSize + ByteCount;
if (CheckIO(err) <> 0) or CommandPeriod then
leave;
if (vloc mod 10) = 0 then ShowAnimatedWatch;
end;
err := SetEof(f, FileSize);
err := fsclose(f);
err := FlushVol(nil, RefNum);
end;
if AutoSelectAll then
KillRoi;
end;
procedure ExportCoordinates (fname: str255; RefNum: integer);
var
err, f, i, y: integer;
TheInfo: FInfo;
ByteCount, FileSize: LongInt;
InvertY: boolean;
begin
if not CoordinatesAvailableMsg then begin
exit(ExportCoordinates)
end;
err := GetFInfo(fname, RefNum, TheInfo);
case err of
NoErr:
if TheInfo.fdType <> 'TEXT' then begin
TypeMismatch(fname);
exit(ExportCoordinates)
end;
FNFerr: begin
err := create(fname, RefNum, TextCreator, 'TEXT');
if CheckIO(err) <> 0 then
exit(ExportCoordinates);
end;
otherwise
if CheckIO(err) <> 0 then
exit(ExportCoordinates)
end;
ShowWatch;
err := fsopen(fname, RefNum, f);
if CheckIO(err) <> 0 then
exit(ExportCoordinates);
FileSize := 0;
InvertY := InvertYCoordinates and (Info <> NoInfo);
with info^ do
for i := 1 to nCoordinates do begin
TextBufSize := 0;
PutLong(xCoordinates^[i] + RoiRect.left, 0);
PutTab;
y := yCoordinates^[i] + RoiRect.top;
if InvertY then
y := PicRect.bottom - y - 1;
PutLong(y, 0);
PutChar(cr);
ByteCount := TextBufSize;
err := fswrite(f, ByteCount, ptr(TextBufP));
FIleSize := FileSize + ByteCount;
if (CheckIO(err) <> 0) or CommandPeriod then
leave;
end;
err := SetEof(f, FileSize);
err := fsclose(f);
err := FlushVol(nil, RefNum);
end;
procedure ExportMeasurements (fname: str255; RefNum: integer);
const
LinesPerPass = 25;
var
err, f, i, first, last: integer;
TheInfo: FInfo;
ByteCount, FileSize: LongInt;
begin
err := GetFInfo(fname, RefNum, TheInfo);
case err of
NoErr:
if TheInfo.fdType <> 'TEXT' then begin
TypeMismatch(fname);
exit(ExportMeasurements)
end;
FNFerr: begin
err := create(fname, RefNum, TextCreator, 'TEXT');
if CheckIO(err) <> 0 then
exit(ExportMeasurements);
end;
otherwise
if CheckIO(err) <> 0 then
exit(ExportMeasurements)
end;
ShowWatch;
err := fsopen(fname, RefNum, f);
if CheckIO(err) <> 0 then
exit(ExportMeasurements);
FileSize := 0;
first := 1;
last := LinesPerPass;
repeat
if last > mCount then
last := mCount;
CopyResultsToBuffer(first, last, ShowHeadings or OptionKeyWasDown);
ByteCount := TextBufSize;
err := fswrite(f, ByteCount, ptr(TextBufP));
FIleSize := FileSize + ByteCount;
if (CheckIO(err) <> 0) or CommandPeriod or (last = mCount) then
leave;
first := first + LinesPerPass;
last := last + LinesPerPass;
until false;
err := SetEof(f, FileSize);
err := fsclose(f);
err := FlushVol(nil, RefNum);
UnsavedResults := false;
end;
procedure Swap2Bytes (var i: integer);
type
atype = packed array[1..2] of char;
var
a: atype;
c: char;
begin
a := atype(i);
c := a[1];
a[1] := a[2];
a[2] := c;
i := integer(a)
end;
procedure Swap4Bytes (var i: LongInt);
var
a: ostype;
c: char;
begin
a := ostype(i);
c := a[1];
a[1] := a[4];
a[4] := c;
c := a[2];
a[2] := a[3];
a[3] := c;
i := LongInt(a)
end;
function OpenTiffHeader (f: integer; var DirOffset: LongInt): boolean;
var
TiffHeader: TiffHdr;
ByteCount: LongInt;
err: OSErr;
begin
ByteCount := 8;
err := SetFPos(f, fsFromStart, 0);
err := fsread(f, ByteCount, @TiffHeader);
if CheckIO(err) <> NoErr then begin
OpenTiffHeader := false;
exit(OpenTiffHeader);
end;
with TiffHeader do begin
IntelByteOrder := ByteOrder = 'II';
if (ByteOrder <> 'MM') and (ByteOrder <> 'II') then begin
PutError('Invalid TIFF header.');
OpenTiffHeader := false;
exit(OpenTiffHeader)
end;
DirOffset := FirstIFDOffset;
if IntelByteOrder then
Swap4Bytes(DirOffset);
OpenTiffHeader := true;
end;
end;
procedure GetTiffEntry (f: integer; var tag: integer; var N, value: LongInt);
var
IFDEntry: TiffEntry;
ByteCount: LongInt;
IntValue: integer;
err: OSErr;
str: str255;
begin
ByteCount := 12;
err := FSRead(f, ByteCount, @IFDEntry);
with IFDEntry do begin
tag := TagField;
N := length;
if IntelByteOrder then begin
Swap2Bytes(tag);
Swap2Bytes(ftype);
Swap4Bytes(N);
end;
value := offset;
if (ftype = short) and (N = 1) then begin
value := bsr(value, 16);
if IntelByteOrder then begin
IntValue := value;
Swap2Bytes(IntValue);
value := IntValue
end
end
else if IntelByteOrder then
Swap4Bytes(value);
if OptionKeyWasDown then begin
gstr := concat(gstr, long2str(tag), ' ', long2str(ftype), ' ', long2str(N), ' ', long2str(value), crStr);
ShowMessage(gstr);
end;
end;
end;
function OpenTiffDirectory (f: integer; DirOffset: LongInt; var TiffInfo: TiffInfoRec; Importing: boolean): boolean;
const
NoUnit = 1;
inch = 2;
centimeter = 3;
var
ByteCount, length, ftype, N, value, BytesPerStrip, SaveFPos: LongInt;
err: OSErr;
nEntries, i, tag, entry: integer;
StripOffsetsArray: array[1..2] of LongInt;
xRes, yRes: extended;
function GetResolution: extended;
var
resolution: array[1..2] of LongInt;
begin
err := GetFPos(f, SaveFPos);
err := SetFPos(f, fsFromStart, value);
ByteCount := 8;
err := fsread(f, ByteCount, @Resolution);
if IntelByteOrder then begin
Swap4Bytes(Resolution[1]);
Swap4Bytes(Resolution[2]);
end;
err := SetFPos(f, fsFromStart, SaveFPos);
if resolution[2] <> 0 then
GetResolution := resolution[1] / resolution[2]
else
GetResolution := 0.0;
end;
begin
if OptionKeyWasDown then
gstr := '';
xRes := 0.0;
err := SetFPos(f, fsFromStart, DirOffset);
ByteCount := 2;
err := FSRead(f, ByteCount, @nEntries);
if CheckIO(err) <> NoErr then begin
OpenTiffDirectory := false;
exit(OpenTiffDirectory);
end;
if IntelByteOrder then
Swap2Bytes(nEntries);
with TiffInfo do begin
width := 0;
height := 0;
BitsPerPixel := 8;
SamplesPerPixel:=1;
PlanarConfig := 1;
OffsetToData := 0;
Resolution := 0.0;
ResUnits := tNoUnits;
OffsetToColorMap := 0;
OffsetToImageHeader := -1;
StripOffsetsArray[1] := 0;
for entry := 1 to nEntries do begin
GetTiffEntry(f, tag, N, value);
if tag = 0 then begin
PutError('Invalid TIFF format.');
OpenTiffDirectory := false;
exit(OpenTiffDirectory)
end;
case tag of
ImageWidth:
width := value;
ImageLength:
height := value;
BitsPerSample: begin
if N = 1 then
BitsPerPixel := value;
if value = 1 then begin
PutError('NIH Image cannot open 1-bit TIFF files.');
OpenTiffDirectory := false;
exit(OpenTiffDirectory)
end;
if (value = 16) and not importing then begin
PutError('Use Import to open 16-bit TIFF files.');
OpenTiffDirectory := false;
exit(OpenTiffDirectory)
end;
end;
SamplesPerPixelTag:
if (value = 1) or (value = 3) then
SamplesPerPixel:=value
else begin
PutError('NIH Image can only open TIFF files with 1 or 3 samples per pixel.');
OpenTiffDirectory := false;
exit(OpenTiffDirectory)
end;
PlanarConfigTag:
PlanarConfig := value;
Compression:
if value <> 1 then begin
PutError('NIH Image cannot open compressed TIFF files.');
OpenTiffDirectory := false;
exit(OpenTiffDirectory)
end;
PhotoInterp:
ZeroIsBlack := value = 1;
StripOffsets:
if N = 1 then
OffsetToData := value
else begin
err := GetFPos(f, SaveFPos);
err := SetFPos(f, fsFromStart, value);
ByteCount := 8;
err := fsread(f, ByteCount, @StripOffsetsArray);
if IntelByteOrder then begin
Swap4Bytes(StripOffsetsArray[1]);
Swap4Bytes(StripOffsetsArray[2]);
end;
err := SetFPos(f, fsFromStart, SaveFPos);
end;
RowsPerStrip:
if (OffsetToData=0) and (value < height) then begin
BytesPerStrip := value * width;
if BitsPerPixel = 16 then
BytesPerStrip := BytesPerStrip * 2
else if SamplesPerPixel = 3 then
BytesPerStrip := BytesPerStrip * 3;
if StripOffsetsArray[1] = 0 then begin
PutError('Invalid TIFF directory.');
OpenTiffDirectory := false;
exit(OpenTiffDirectory)
end;
if StripOffsetsArray[2] <> (StripOffsetsArray[1] + BytesPerStrip) then begin
PutError('NIH Image cannot open TIFF files with discontiguous strips.');
OpenTiffDirectory := false;
exit(OpenTiffDirectory)
end;
OffsetToData := StripOffsetsArray[1];
end;
XResolution:
XRes := GetResolution;
YResolution: begin
yRes := GetResolution;
if (xRes = yRes) and (xRes > 0.0) then begin
resolution := xRes;
ResUnits := tInches;
end;
end;
ResolutionUnit:
case value of
NoUnit:
ResUnits := tNoUnits;
Centimeter:
ResUnits := tCentimeters;
otherwise
end;
ColorMapTag:
if N = 768 then
OffsetToColorMap := value;
ImageHdrTag:
OffsetToImageHeader := value;
otherwise
end;
end; {for}
ByteCount := 4;
err := FSRead(f, ByteCount, @NextIFD);
if IntelByteOrder then
Swap4Bytes(NextIFD);
if OptionKeyWasDown then begin
gstr := concat(gstr, 'Next IFD=', long2str(NextIFD));
ShowMessage(gstr);
end;
if width = 0 then begin
PutError('Error opening TIFF directory');
OpenTiffDirectory := false;
exit(OpenTiffDirectory)
end;
if (SamplesPerPixel = 3) and (PlanarConfig <> 1) then begin
PutError('NIH Image cannot open RGB files with separate planes.');
OpenTiffDirectory := false;
exit(OpenTiffDirectory)
end;
end; {with}
OpenTiffDirectory := true;
end;
procedure SaveTiffColorMap (f: integer; ImageDataSize: LongInt);
var
i: integer;
err: OSErr;
ColorMap: TiffColorMapType;
ColorMapSize: LongInt;
begin
LoadLUT(info^.cTable);
if ScreenDepth=8 then begin
for i := 0 to 255 do
with cScreenPort^.portPixMap^^.pmTable^^.ctTable[i].rgb do begin
ColorMap[1, i] := red;
ColorMap[2, i] := green;
ColorMap[3, i] := blue;
end;
end else begin
for i := 0 to 255 do
with info^.cTable[i].rgb do begin
ColorMap[1, i] := red;
ColorMap[2, i] := green;
ColorMap[3, i] := blue;
end;
end;
err := SetFPos(f, FSFromStart, HeaderSize + TiffDirSize + ImageDataSize);
ColorMapSize := SizeOf(ColorMap);
err := fswrite(f, ColorMapSize, @ColorMap);
if CheckIO(err) <> 0 then
beep;
end;
procedure GetTiffColorMap (f: integer);
var
i: integer;
ByteCount: LongInt;
err: OSErr;
ColorMap: TiffColorMapType;
begin
with info^ do begin
ByteCount := SizeOf(ColorMap);
err := SetFPos(f, fsFromStart, ColorMapOffset);
err := fsRead(f, ByteCount, @ColorMap);
if err = NoErr then begin
if IntelByteOrder then
for i := 0 to 255 do begin
Swap2Bytes(ColorMap[1, i]);
Swap2Bytes(ColorMap[2, i]);
Swap2Bytes(ColorMap[3, i]);
end;
for i := 0 to 255 do
with cTable[i].rgb do begin
red := ColorMap[1, i];
green := ColorMap[2, i];
blue := ColorMap[3, i];
end;
LoadLUT(cTable);
LUTMode := ColorLut;
SetupPseudocolor;
IdentityFunction := false;
if isGrayScaleLUT then begin
info^.LutMode := CustomGrayScale;
DrawMap;
end;
end
else
beep;
end;{with}
end;
function SaveTiffDir (f, slines, sPixelsPerLine: integer; SavingSelection: boolean; ctabSize, ImageDataSize: LongInt): OSErr;
var
i: integer;
err: OSErr;
SavingStack, SavingRGBStack: boolean;
ByteCount, width, height: LongInt;
TiffInfo1: record
Header: TiffHdr; {8}
nEntries: integer; {2}
TiffDir: array[1..9] of TiffEntry; {108}
end;
ColorMapEntry: TiffEntry; {12 (Optional)}
TiffInfo2: record
ImageHdrEntry: TiffEntry; {12}
NextIFD: LongInt; {4}
BitsPerPixelData: array[1..3] of integer; {6} {only used for RGB files}
filler: array[1..TiffFillerSize] of integer; {116}
end;
BitsPerSampleData: record
rBitsPerSample, gBitsPerSample, bBitsPerSample:integer;
end;
begin
with info^ do begin
SavingStack := false;
SavingRGBStack := false;
if StackInfo <> nil then
SavingStack := StackInfo^.nSlices > 1;
if SavingStack then
if (StackInfo^.StackType = rgbStack) and (StackInfo^.nSlices = 3) then begin
SavingRGBStack := true;
ctabSize := 0;
end;
if SavingSelection then begin
width := sPixelsPerLine;
height := sLines
end
else begin
width := PixelsPerLine;
height := nLines
end;
with TiffInfo1 do begin
with header do begin
ByteOrder := 'MM';
Version := 42;
FirstIFDOffset := 8;
end;
if ctabSize > 0 then
nEntries := 11
else
nEntries := 10;
for i := 1 to 9 do
with TiffDir[i] do begin
ftype := 3;
length := 1
end;
with TiffDir[1] do begin
TagField := NewSubfileType;
ftype := 4;
offset := 0;
end;
with TiffDir[2] do begin
TagField := ImageWidth;
offset := bsl(width, 16);
end;
with TiffDir[3] do begin
TagField := ImageLength;
offset := bsl(height, 16);
end;
with TiffDir[4] do begin
TagField := BitsPerSample;
if SavingRGBStack then begin
ftype := 3;
length := 3;
offset := SizeOf(TiffInfo1) + SizeOf(TiffEntry) + SizeOf(LongInt);
with TiffInfo2 do
for i := 1 to 3 do
BitsPerPixelData[i] := 8;
end else begin
offset := bsl(8, 16);
with TiffInfo2 do
for i := 1 to 3 do
BitsPerPixelData[i] := 0;
end;
end;
with TiffDir[5] do begin
TagField := PhotoInterp;
if SavingRGBStack then
offset := bsl(2, 16)
else if ctabSize > 0 then
offset := bsl(3, 16)
else
offset := 0;
end;
with TiffDir[6] do begin
TagField := StripOffsets;
ftype := 4;
offset := TiffDirSize + HeaderSize;
end;
with TiffDir[7] do begin
TagField := SamplesPerPixelTag;
if SavingRGBStack then
offset := bsl(3, 16)
else
offset := bsl(1, 16);
end;
with TiffDir[8] do begin
TagField := RowsPerStrip;
offset := bsl(height, 16);
end;
with TiffDir[9] do begin
TagField := StripByteCount;
ftype := 4;
if SavingRGBStack then
offset := width * height * 3
else
offset := width * height;
end;
end;
ByteCount := SizeOf(TiffInfo1);
err := SetFPos(f, FSFromStart, 0);
err := FSWrite(f, ByteCount, @TiffInfo1);
if CheckIO(err) <> NoErr then begin
SaveTiffDir := err;
exit(SaveTiffDir);
end;
if ctabSize > 0 then
with ColorMapEntry do begin
TagField := ColorMapTag;
ftype := 3;
length := 768;
offset := HeaderSize + TiffDirSize + ImageDataSize;
ByteCount := SizeOf(ColorMapEntry);
err := FSWrite(f, ByteCount, @ColorMapEntry);
if CheckIO(err) <> NoErr then begin
SaveTiffDir := err;
exit(SaveTiffDir);
end;
end;
with TiffInfo2 do begin
with ImageHdrEntry do begin
TagField := ImageHdrTag;
ftype := 3;
length := 256;
offset := TiffDirSize;
end;
NextIFD := 0;
if SavingStack then
NextIFD := HeaderSize + TiffDirSize + ImageDataSize + ctabSize;
for i := 1 to TiffFillerSize do
filler[i] := 0;
end;
end; {with info^}
ByteCount := SizeOf(TiffInfo2);
err := FSWrite(f, ByteCount, @TiffInfo2);
SaveTiffDir := CheckIO(err);
end;
function WriteExtraTiffIFDs (f: integer; ImageDataSize, cTabSize: LongInt): integer;
var
IFD, entry: integer;
StackIFD: StackIFDType;
err: OSErr;
IFDoffset, SliceOffset, ByteCount: LongInt;
begin
with info^, StackInfo^, StackIFD do begin
IFDoffset := HeaderSize + TiffDirSize + ImageDataSize + ctabSize;
err := SetFPos(f, FSFromStart, IFDoffset);
SliceOffset := HeaderSize + TiffDirSize + ImageSize;
for IFD := 2 to nSlices do {IFD=Image File Directory}
begin
nEntries := 6;
for entry := 1 to nEntries do
with TiffDir[entry] do begin
ftype := 3;
length := 1
end;
with TiffDir[1] do begin
TagField := NewSubfileType;
ftype := 4;
offset := 0;
end;
with TiffDir[2] do begin
TagField := ImageWidth;
offset := bsl(PixelsPerLine, 16);
end;
with TiffDir[3] do begin
TagField := ImageLength;
offset := bsl(nLines, 16);
end;
with TiffDir[4] do begin
TagField := BitsPerSample;
offset := bsl(8, 16);
end;
with TiffDir[5] do begin
TagField := PhotoInterp;
offset := 0;
end;
with TiffDir[6] do begin
TagField := StripOffsets;
ftype := 4;
offset := SliceOffset;
end;
SliceOffset := SliceOffset + ImageSize;
IFDoffset := IFDoffset + SizeOf(StackIFD);
if IFD <> nSlices then
NextIFD := IFDoffset
else
NextIFD := 0;
ByteCount := SizeOf(StackIFD);
err := fswrite(f, ByteCount, @StackIFD);
if err <> NoErr then begin
WriteExtraTiffIFDs := err;
exit(WriteExtraTiffIFDs);
end;
end; {for}
end; {with}
WriteExtraTiffIFDs := NoErr;
end;
procedure SaveLUT (fname: str255; RefNum: integer);
var
err: integer;
TheInfo: FInfo;
LUT: array[1..3] of packed array[0..255] of byte;
i, f: integer;
ByteCount: LongInt;
begin
err := GetFInfo(fname, RefNum, TheInfo);
case err of
NoErr:
if TheInfo.fdType <> 'ICOL' then begin
TypeMismatch(fname);
exit(SaveLUT)
end;
FNFerr: begin
err := create(fname, RefNum, 'Imag', 'ICOL');
if CheckIO(err) <> 0 then
exit(SaveLUT);
end;
otherwise
if CheckIO(err) <> 0 then
exit(SaveLUT);
end;
DisableDensitySlice;
LoadLUT(Info^.cTable);
for i := 0 to 255 do
with cScreenPort^.portPixMap^^.pmTable^^.ctTable[i].rgb do begin
LUT[1, i] := band(bsr(red, 8), 255);
LUT[2, i] := band(bsr(green, 8), 255);
LUT[3, i] := band(bsr(blue, 8), 255);
end;
err := fsopen(fname, RefNum, f);
if CheckIO(err) <> 0 then
exit(SaveLUT);
err := SetFPos(f, FSFromStart, 0);
ByteCount := SizeOf(LUT);
err := fswrite(f, ByteCount, @LUT);
if CheckIO(err) <> 0 then begin
err := fsclose(f);
err := FSDelete(fname, RefNum);
exit(SaveLUT)
end;
err := SetEof(f, ByteCount);
err := fsclose(f);
err := GetFInfo(fname, RefNum, TheInfo);
if TheInfo.fdCreator <> 'Imag' then begin
TheInfo.fdCreator := 'Imag';
err := SetFInfo(fname, RefNum, TheInfo);
end;
err := FlushVol(nil, RefNum);
end;
procedure SaveColorTable (fname: str255; RefNum: integer);
var
err: integer;
TheInfo: FInfo;
i, f: integer;
ByteCount: LongInt;
hdr: PaletteHeader;
begin
with info^ do
err := GetFInfo(fname, RefNum, TheInfo);
case err of
NoErr:
if TheInfo.fdType <> 'ICOL' then begin
TypeMismatch(fname);
exit(SaveColorTable)
end;
FNFerr: begin
err := create(fname, RefNum, 'Imag', 'ICOL');
if CheckIO(err) <> 0 then
exit(SaveColorTable);
end;
otherwise
if CheckIO(err) <> 0 then
exit(SaveColorTable);
end;
with info^ do begin
InitPaletteHeader(hdr);
err := fsopen(fname, RefNum, f);
if CheckIO(err) <> 0 then
exit(SaveColorTable);
err := SetFPos(f, FSFromStart, 0);
ByteCount := SizeOf(PaletteHeader);
if ByteCount <> 32 then
PutError('Palette header size <> 32.');
err := fswrite(f, ByteCount, @hdr);
ByteCount := nColors;
err := fswrite(f, ByteCount, @redLUT);
ByteCount := nColors;
err := fswrite(f, ByteCount, @greenLUT);
ByteCount := nColors;
err := fswrite(f, ByteCount, @blueLUT);
if CheckIO(err) <> 0 then begin
err := fsclose(f);
err := FSDelete(fname, RefNum);
exit(SaveColorTable)
end;
err := SetEOF(f, SizeOf(PaletteHeader) + 3 * nColors);
err := fsclose(f);
err := GetFInfo(fname, RefNum, TheInfo);
if TheInfo.fdCreator <> 'Imag' then begin
TheInfo.fdCreator := 'Imag';
err := SetFInfo(fname, RefNum, TheInfo);
end;
err := FlushVol(nil, RefNum);
end; {with info^}
end;
procedure SaveOutline (fname: str255; RefNum: integer);
var
err: integer;
TheInfo: FInfo;
i, f: integer;
ByteCount, DataSize: LongInt;
hdr: RoiHeader;
SaveCoordinates: boolean;
dX1, dY1, dX2, dY2: extended;
begin
with info^ do begin
if not RoiShowing then begin
PutError('No outline available to save.');
exit(SaveOutline);
end;
if (RoiType = FreeLineRoi) or (RoiType = SegLineRoi) then begin
PutError('Freehand and segmented line selections cannot be saved.');
exit(SaveOutline);
end;
SaveCoordinates := (RoiType = PolygonRoi) or (RoiType = FreehandRoi);
if SaveCoordinates then
if not CoordinatesAvailableMsg then begin
exit(SaveOutline);
end;
err := GetFInfo(fname, RefNum, TheInfo);
case err of
NoErr:
if TheInfo.fdType <> 'Iout' then begin
TypeMismatch(fname);
exit(SaveOutline)
end;
FNFerr: begin
err := create(fname, RefNum, 'Imag', 'Iout');
if CheckIO(err) <> 0 then
exit(SaveOutline);
end;
otherwise
if CheckIO(err) <> 0 then
exit(SaveOutline);
end;
with hdr do begin
rID := 'Iout';
rVersion := version;
rRoiType := RoiType;
rRoiRect := RoiRect;
rNCoordinates := nCoordinates;
GetLoi(dX1, dY1, dX2, dY2);
rX1:=dX1; rY1:=dY1; rX2:=dX2; rY2:=dY2;
rLineWidth := LineWidth;
for i := 1 to 14 do
rUnused[i] := 0;
end;
err := fsopen(fname, RefNum, f);
if CheckIO(err) <> 0 then
exit(SaveOutline);
err := SetFPos(f, FSFromStart, 0);
ByteCount := SizeOf(RoiHeader);
if ByteCount <> 64 then
PutError('Roi header size <> 32.');
err := fswrite(f, ByteCount, @hdr);
if SaveCoordinates then begin
ByteCount := nCoordinates * 2;
err := fswrite(f, ByteCount, ptr(xCoordinates));
ByteCount := nCoordinates * 2;
err := fswrite(f, ByteCount, ptr(yCoordinates));
DataSize := nCoordinates * 4;
end
else
DataSize := 0;
if CheckIO(err) <> 0 then begin
err := fsclose(f);
err := FSDelete(fname, RefNum);
exit(SaveOutline)
end;
err := SetEOF(f, SizeOf(RoiHeader) + DataSize);
err := fsclose(f);
err := GetFInfo(fname, RefNum, TheInfo);
if TheInfo.fdCreator <> 'Imag' then begin
TheInfo.fdCreator := 'Imag';
err := SetFInfo(fname, RefNum, TheInfo);
end;
err := FlushVol(nil, RefNum);
end; {with info^}
end;
procedure OpenOutline (fname: str255; RefNum: integer);
var
err, f, i: integer;
count: LongInt;
hdr: RoiHeader;
okay: boolean;
begin
if Info = NoInfo then begin
if (NewPicWidth * NewPicHeight) <= UndoBufSize then begin
if not NewPicWindow('Untitled', NewPicWidth, NewPicHeight) then
exit(OpenOutline)
end
else begin
beep;
exit(OpenOutline)
end;
end;
KillRoi;
err := fsopen(fname, RefNum, f);
with info^, hdr do begin
count := SizeOf(RoiHeader);
err := fsread(f, count, @hdr);
if rID <> 'Iout' then begin
err := fsclose(f);
PutError('File is corrupted.');
exit(OpenOutline)
end;
if (rRoiRect.right > PicRect.right) or (rRoiRect.bottom > PicRect.bottom) then begin
err := fsclose(f);
PutError('Image is too small for the outline.');
exit(OpenOutline)
end;
case rRoiType of
LineRoi: begin
LX1 := rX1;
LY1 := rY1;
LX2 := rX2;
LY2 := rY2;
RoiType := LineRoi;
MakeRegion;
SetupUndo;
RoiShowing := true;
end;
RectRoi, OvalRoi: begin
RoiType := rRoiType;
RoiRect := rRoiRect;
MakeRegion;
SetupUndo;
RoiShowing := true;
end;
PolygonRoi, FreehandRoi:
if (rNCoordinates > 2) and (rNCoordinates <= MaxCoordinates) then begin
count := rNCoordinates * 2;
err := fsread(f, count, ptr(xCoordinates));
count := rNCoordinates * 2;
err := fsread(f, count, ptr(yCoordinates));
if CheckIO(err) = 0 then begin
nCoordinates := rNCoordinates;
SelectionMode := NewSelection;
if rVersion >= 148 then
for i := 1 to nCoordinates do
with rRoiRect do begin
xCoordinates^[i] := xCoordinates^[i] + left;
yCoordinates^[i] := yCoordinates^[i] + top;
end;
MakeOutline(rRoiType);
SetupUndo;
end;
end;
end;
end;
err := fsclose(f);
end;
function GetTIFFParameters (name: str255; RefNum: integer; var HasColorMap: boolean): boolean;
var
err: OSErr;
f: integer;
DirOffset: LongInt;
TiffInfo: TiffInfoRec;
begin
GetTIFFParameters := false;
HasColorMap := false;
err := fsopen(name, RefNum, f);
if err <> NoErr then
exit(GetTIFFParameters);
if not OpenTiffHeader(f, DirOffset) then begin
err := fsclose(f);
exit(GetTIFFParameters)
end;
if not OpenTiffDirectory(f, DirOffset, TiffInfo, true) then begin
err := fsclose(f);
exit(GetTIFFParameters)
end;
with TiffInfo do begin
ImportCustomWidth := width;
ImportCustomHeight := height;
ImportCustomOffset := OffsetToData;
ImportAutoScale:=true;
if BitsPerPixel = 16 then begin
ImportCustomDepth := SixteenBitsUnsigned;
ImportSwapBytes := IntelByteOrder;
end
else begin
ImportCustomDepth := EightBits;
ImportInvert := ZeroIsBlack;
end;
HasColorMap := OffsetToColorMap > 0;
end;
if ImportCustomDepth = EightBits then begin
WhatToImport := ImportTiff;
WhatToOpen := OpenTiff
end else begin
WhatToImport := ImportCustom;
WhatToOpen := OpenCustom
end;
err := fsclose(f);
GetTIFFParameters := true;
end;
procedure GetXUnits (UnitsKind: UnitsType);
begin
with info^ do
case UnitsKind of
Nanometers:
xUnit := 'nm';
Micrometers:
xUnit := 'ľm';
Millimeters:
xUnit := 'mm';
Centimeters:
xUnit := 'cm';
Meters:
xUnit := 'meter';
Kilometers:
xUnit := 'km';
Inches:
xUnit := 'inch';
feet:
xUnit := 'ft';
Miles:
xUnit := 'mile';
Pixels:
xUnit := 'pixel';
otherwise
;
end;
end;
procedure GetUnitsKInd (var UnitsKind: UnitsType; var UnitsPerCM: extended);
begin
with info^ do begin
if xunit = 'nm' then begin
UnitsKind := Nanometers;
UnitsPerCm := 10000000.0;
end
else if xUnit = 'ľm' then begin
UnitsKind := Micrometers;
UnitsPerCm := 10000.0;
end
else if xUnit = 'mm' then begin
UnitsKind := Millimeters;
UnitsPerCm := 10.0;
end
else if xUnit = 'cm' then begin
UnitsKind := Centimeters;
UnitsPerCm := 1.0;
end
else if xUnit = 'meter' then begin
UnitsKind := Meters;
UnitsPerCm := 0.01;
end
else if xUnit = 'km' then begin
UnitsKind := Kilometers;
UnitsPerCm := 0.00001;
end
else if xUnit = 'inch' then begin
UnitsKind := Inches;
UnitsPerCm := 0.3937;
end
else if xUnit = 'ft' then begin
UnitsKind := feet;
UnitsPerCm := 0.0328083;
end
else if xUnit = 'mile' then begin
UnitsKind := Miles;
UnitsPerCm := 0.000006213;
end
else if xUnit = 'pixel' then begin
UnitsKind := pixels;
UnitsPerCm := 0.0;
SpatiallyCalibrated := false;
end
else begin
UnitsKind := OtherUnits;
UnitsPerCm := 0.0;
end;
end;
end;
end.