home *** CD-ROM | disk | FTP | other *** search
Text File | 1995-10-23 | 94.9 KB | 3,309 lines | [ TEXT/PJMM]
unit File1; {Routines used by NIH Image for implementing File Menu commands.} interface uses Memory, QuickDraw, Packages, Menus, Events, Fonts, Scrap, ToolUtils, Resources, Errors, Palettes, StandardFile, SegLoad, Processes, globals, Utilities, Graphics, file2, Dicom, sound, Lut, Text; function CloseAWindow (WhichWindow: WindowPtr): integer; procedure DoClose; function OpenFile (fname: str255; vnum: integer): boolean; function OpenPict (fname: str255; vnum: integer; Reverting: boolean): boolean; procedure SaveFile; function DoOpen (FileName: str255; RefNum: integer): boolean; function ImportFile (FileName: str255; RefNum: integer): boolean; procedure RevertToSaved; procedure SaveAs (name: str255; RefNum: integer); procedure Export (name: str255; RefNum: integer); procedure FindWhatToPrint; procedure UpdateFileMenu; procedure SaveAsText (fname: str255; RefNum: integer); procedure SaveAll; function OpenPICS (name: str255; fRefNum: integer): boolean; procedure RescaleToEightBits; implementation var OpenAllFiles, UseExistingLUT, PICTReadErr: boolean; SaveRefNum: integer; TempStackInfo: StackInfoRec; PictSrcRect: rect; {$PUSH} {$D-} procedure LookForCluts (fname: str255; vnum: integer); var RefNum: integer; err: OSErr; ok1, ok2: boolean; begin if not UseExistingLUT then begin err := SetVol(nil, vnum); refNum := OpenResFile(fname); if RefNum <> -1 then begin ok1 := LoadCLUTResource(KlutzID); if not ok1 then ok2 := LoadCLUTResource(PixelPaintID); CloseResFile(refNum); end; end; end; function OpenImageHeader (f: integer; fname: str255; vnum: integer): boolean; var ByteCount: LongInt; err: OSErr; TempHdr: PicHeader; i, OldNExtra, p1x, p2x: integer; ok: boolean; hUnitsKind: UnitsType; begin if SizeOf(PicHeader)<>HeaderSize then begin PutError(StringOf('Internal error (size= ', SizeOf(PicHeader):1,')')); OpenImageHeader := false; exit(OpenImageHeader); end; ByteCount := HeaderSize; err := SetFPos(f, fsFromStart, info^.HeaderOffset); err := fsread(f, ByteCount, @TempHdr); if CheckIO(err) <> NoErr then begin OpenImageHeader := false; exit(OpenImageHeader); end; with info^, TempHdr do begin if PictureType <> TiffFile then begin nlines := hnlines; PixelsPerLine := hPixelsPerLine; end; if (hversion > 54) and not UseExistingLUT then begin OldNExtra := nExtraColors; nExtraColors := hnExtraColors; ExtraColors := hExtraColors; if (nExtraColors > 0) or (OldNExtra <> nExtraColors) then RedrawLUTWindow; end; if (hversion >= 42) and not UseExistingLUT then begin if hversion < 142 then begin LUTMode := hOldLUTMode; if (LutMode = OldAppleDefault) or (LutMode = OldSpectrum) then LutMode := ColorLut; end else begin LUTMode := hLUTMode; if LutMode = Pseudocolor then begin if ((hnColors > 32) and (hTable = CustomTable)) or (hTable > spectrum) then LutMode := ColorLut; end; end; case LUTMode of PseudoColor: if hversion < 142 then begin nColors := hOldnColors; for i := 0 to ncolors - 1 do begin RedLUT[i] := hr[i]; GreenLUT[i] := hg[i]; BlueLUT[i] := hb[i]; end; ColorEnd := 255 - hOldColorStart; ColorStart := ColorEnd - nColors * hColorWidth + 1; if ColorStart < 0 then ColorStart := 0; InvertPalette; FillColor1 := BlackRGB; FillColor2 := BlackRGB; ColorTable := CustomTable; UpdateLUT; end else begin {V1.42 or later} if (hTable <> CustomTable) and (hTable <= spectrum) then begin SwitchColorTables(GetColorTableItem(hTable), false); if hInvertedTable then InvertPalette; end else begin nColors := hnColors; ColorTable := CustomTable; if nColors <= 32 then for i := 0 to ncolors - 1 do begin RedLUT[i] := hr[i]; GreenLUT[i] := hg[i]; BlueLUT[i] := hb[i]; end; end; ColorStart := hColorStart; ColorEnd := hColorEnd; FillColor1 := hFill1; FillColor2 := hFill2; UpdateLUT; UpdateMap; end; {v1.42 or later} GrayScale: ResetGrayMap; ColorLut, CustomGrayscale: if PictureType <> PictFile then begin if ColorMapOffset > 0 then GetTiffColorMap(f) else LookForCluts(fname, vnum); end; otherwise end; {case} if hLutMode = CustomGrayscale then LutMode := CustomGrayscale; end;{if} if (hversion >= 65) and ((ForegroundIndex <> hForegroundIndex) or (BackgroundIndex <> hBackgroundIndex)) then begin SetForegroundColor(hForegroundIndex); SetBackgroundColor(hBackgroundIndex); end; if (hversion > 88) and (LUTMode = GrayScale) and not UseExistingLUT then begin if hversion < 138 then begin p1x := 255 - hp2x; p2x := 255 - hp1x; end else begin p1x := hp1x; p2x := hp2x end; nColors := 256; ColorStart := p1x; ColorEnd := p2x; UpdateLUT; end; if hversion > 106 then begin {xScale := hXScale;} {68k-bug} xScale := DoubleToReal(hXScale); yScale := xScale; PixelAspectRatio := 1.0; SpatiallyCalibrated := xScale <> 0.0; end; if hversion > 140 then begin PixelAspectRatio := hPixelAspectRatio; yScale := xScale / PixelAspectRatio; end; if hversion > 153 then xUnit := hXUnit else begin hUnitsKind := UnitsType(hUnitsID - 5); GetXUnits(hUnitsKind); end; if xUnit = 'pixel' then SpatiallyCalibrated := false; if ((hnCoefficients > 0) and (hfit < Uncalibrated)) or (hfit = UncalibratedOD) then begin if hfit = SpareFit1 then begin fit := uncalibrated; DrawLabels('', '', ''); end else begin fit := hfit; if hfit <> UncalibratedOD then begin nCoefficients := hnCoefficients; for i:=1 to maxCoeff do {Coefficient[i] := hCoeff[i];} {68k-bug} Coefficient[i]:=DoubleToReal(hCoeff[i]); nKnownValues := 0; end; UnitOfMeasure := hUM; if hversion >= 144 then ZeroClip := hZeroClip else ZeroClip := false; end; end else begin fit := uncalibrated; DrawLabels('', '', ''); end; BinaryPic := hBinaryPic; if hSliceEnd > 1 then begin SliceStart := hSliceStart; SliceEnd := hSliceEnd; if SliceEnd > 254 then SliceEnd := 254; end; if hNSlices > 1 then begin with TempStackInfo do begin nSlices := hNSlices; if nSlices > MaxSlices then nSlices := MaxSlices; CurrentSlice := hCurrentSlice; if (hCurrentSlice < 1) or (hCurrentSlice > nSlices) then CurrentSlice := 1; SliceSpacing := hSliceSpacing; FrameInterval := hFrameInterval; StackType := VolumeStack; if hVersion >= 158 then StackType := hStackType; end; end; FileVersion := hVersion; OpenImageHeader := true end; end; function OpenHeader (f: integer; fname: str255; vnum: integer; var TiffInfo: TiffInfoRec): boolean; var ByteCount, FileSize, DirOffset, MaxImages: LongInt; hdr: packed array[1..512] of byte; err: OSErr; TempHdr: PicHeader; begin with info^ do begin if (WhatToOpen = OpenUnknown) or (WhatToOpen = OpenImported) then begin err := SetFPos(f, fsFromStart, 0); ByteCount := 8; err := fsread(f, ByteCount, @hdr); if ((hdr[1] = 73) and (hdr[2] = 73)) or ((hdr[1] = 77) and (hdr[2] = 77)) then WhatToOpen := OpenTIFF else if WhatToOpen = OpenUnknown then WhatToOpen := OpenImage else WhatToOpen := OpenMCID; end; StackInfo := nil; with TempStackInfo do begin nSlices := 0; CurrentSlice := 1; SliceSpacing := 0.0; FrameInterval := 0.0; end; fileVersion := 0; case WhatToOpen of OpenImage: begin err := SetFPos(f, fsFromStart, 0); ByteCount := 8; err := fsread(f, ByteCount, @TempHdr); if TempHdr.FileID = FileID8 then begin HeaderOffset := 0; PictureType := normal end else begin HeaderOffset := -1; BlockMove(@TempHdr, @hdr, 8); nlines := hdr[1] + hdr[2] * 256; PixelsPerLine := hdr[3] + hdr[4] * 256; PictureType := Imported; InvertedImage := true; end; ImageDataOffset := 512; end; OpenMCID: begin err := SetFPos(f, fsFromStart, 0); ByteCount := 4; err := fsread(f, ByteCount, @hdr); PixelsPerLine := hdr[1] + hdr[2] * 256 + 1; if PixelsPerLine > MaxLine then begin beep; PixelsPerLine := MaxLine; end; nlines := hdr[3] + hdr[4] * 256 + 1; PictureType := imported; LUTMode := grayscale; HeaderOffset := -1; ImageDataOffset := 4; end; OpenCustom: begin err := GetEof(f, FileSize); if macro then begin if (ImportCustomOffset + ImportCustomWidth * ImportCustomHeight) > FileSize then begin AbortMacro; OpenHeader := false; exit(OpenHeader) end; end; PixelsPerLine := ImportCustomWidth; nlines := ImportCustomHeight; PictureType := imported; HeaderOffset := -1; ImageDataOffset := ImportCustomOffset; if ImportCustomSlices > 1 then with TempStackInfo do begin nSlices := ImportCustomSlices; MaxImages := (FileSize - ImportCustomOffset) div (ImportCustomWidth * ImportCustomHeight); if nSlices > MaxImages then nSlices := MaxImages; if nSlices < 2 then nSlices := 0; end; end; OpenPICT2: begin err := SetFPos(f, fsFromStart, 0); ByteCount := 8; err := fsread(f, ByteCount, @TempHdr); if TempHdr.FileID = FileID8 then HeaderOffset := 0 else HeaderOffset := -1; PictureType := PictFile; if not UseExistingLUT then LutMode := ColorLut; ImageDataOffset := 512; end; OpenTIFF: begin if not OpenTiffHeader(f, DirOffset) then begin OpenHeader := false; exit(OpenHeader) end; if not OpenTiffDirectory(f, DirOffset, TiffInfo, false) then begin OpenHeader := false; exit(OpenHeader) end; with TiffInfo do begin PictureType := TiffFile; PixelsPerLine := width; nlines := height; if BitsPerPixel = 4 then PictureType := FourBitTiff; ImageDataOffset := OffsetToData; InvertedImage := ZeroIsBlack and (PictureType <> FourBitTIFF); if resolution > 0.0 then begin case ResUnits of tNoUnits: xUnit := 'pixel'; tCentimeters: xUnit := 'cm'; tInches: xUnit := 'inch'; end; xScale := resolution; yScale := resolution; PixelAspectRatio := 1.0; if xUnit <> 'pixel' then SpatiallyCalibrated := true; end; ColorMapOffset := OffsetToColorMap; HeaderOffset := OffsetToImageHeader; end; if not UseExistingLUT then LutMode := Grayscale; end; end; {case} if HeaderOffset <> -1 then begin if not OpenImageHeader(f, fname, vnum) then begin OpenHeader := false; exit(OpenHeader) end end else if (ColorMapOffset > 0) and not UseExistingLUT then GetTiffColorMap(f); end; {with} OpenHeader := true; end; function SaveHeader (f, slines, sPixelsPerLine, vnum: integer; fname: str255; SavingSelection, SavingTIFF: boolean): OSErr; var TempHdr: PicHeader; DummyHdr: array[1..128] of LongInt; i: integer; ByteCount: LongInt; position: LongInt; err: OSErr; str: str255; UnitsKind: UnitsType; UnitsPerCM: extended; begin with TempHdr, info^ do begin for i := 1 to 128 do DummyHdr[i] := 0; BlockMove(@DummyHdr, @TempHdr, HeaderSize); FileID := FileID8; hnlines := nlines; hPixelsPerLine := PixelsPerLine; hversion := version; hLUTMode := LUTMode; hOldLutMode := LutMode; hnColors := ncolors; hOldnColors := 0; if LutMode = Pseudocolor then begin hOldLutMode := ColorLut; if (ColorTable = CustomTable) and (ncolors <= 32) then for i := 0 to nColors - 1 do begin hr[i] := RedLUT[i]; hg[i] := GreenLUT[i]; hb[i] := BlueLUT[i]; end; end; hColorStart := ColorStart; hColorEnd := ColorEnd; hFill1 := FillColor1; hFill2 := FillColor2; hTable := ColorTable; hInvertedTable := InvertedColorTable; hOldColorStart := 255 - ColorEnd; if nColors > 0 then hColorWidth := (ColorEnd - ColorStart) div nColors else hColorWidth := 1; hnExtraColors := nExtraColors; hExtraColors := ExtraColors; hForegroundIndex := ForegroundIndex; hBackgroundIndex := BackgroundIndex; {hXScale := xScale;} {68k-bug} RealToDouble(xScale, hXScale); hScaleMagnification := 1.0; hPixelAspectRatio := PixelAspectRatio; hUnitsID := 14; {Pixels. For backward compatibility only since hUnits no longer used.} if SpatiallyCalibrated then begin GetUnitsKind(UnitsKind, UnitsPerCM); hUnitsID := ord(UnitsKind) + 5; if hUnitsID > 14 then hUnitsID := 14; end; FindPoints(hp1x, hp1y, hp2x, hp2y); if fit = uncalibrated then hnCoefficients := 0 else hnCoefficients := nCoefficients; hfit := fit; for i:=1 to maxCoeff do {hCoeff[i] := Coefficient[i];} {68k-bug} RealToDouble(Coefficient[i], hCoeff[i]); hZeroClip := ZeroClip; hUM := UnitOfMeasure; hBinaryPic := BinaryPic; hSliceStart := SliceStart; hSliceEnd := SliceEnd; if StackInfo <> nil then with StackInfo^ do begin hNSlices := nSlices; hSliceSpacing := SliceSpacing; hFrameInterval := FrameInterval; hCurrentSlice := CurrentSlice; hStackType := StackType; end else begin hNSlices := 0; hSliceSpacing := 0.0; hFrameInterval := 0.0; hCurrentSlice := 0; hStackType := VolumeStack; end; hXUnit := xUnit; ByteCount := SizeOf(TempHdr); if ByteCount <> HeaderSize then begin NumToString(ByteCount, str); PutError('Internal error check: header size is incorrect.'); ExitToShell; end; if SavingSelection then begin hnlines := slines; hPixelsPerLine := sPixelsPerLine; end; err := fswrite(f, ByteCount, @TempHdr); SaveHeader := CheckIO(err); end; {with} end; procedure PackLines; {For odd width images, removes the extra bytes at the end of each line required to make RowBytes even.} var i: integer; SrcPtr, DstPtr: ptr; begin with info^ do begin SrcPtr := ptr(ord4(PicBaseAddr) + BytesPerRow); DstPtr := ptr(ord4(PicBaseAddr) + PixelsPerLine); for i := 1 to nlines - 1 do begin BlockMove(SrcPtr, DstPtr, PixelsPerLine); SrcPtr := ptr(ord4(SrcPtr) + BytesPerRow); DstPtr := ptr(ord4(DstPtr) + PixelsPerLine); end; end; end; procedure UnpackLines; {For odd width images, adds an extra byte to each line so RowBytes is even.} var i: integer; SrcPtr, DstPtr: ptr; begin with info^ do begin SrcPtr := ptr(ord4(PicBaseAddr) + (nlines - 1) * PixelsPerLine); DstPtr := ptr(ord4(PicBaseAddr) + (nlines - 1) * BytesPerRow); for i := 1 to nlines - 1 do begin BlockMove(SrcPtr, DstPtr, PixelsPerLine); SrcPtr := ptr(ord4(SrcPtr) - PixelsPerLine); DstPtr := ptr(ord4(DstPtr) - BytesPerRow); end; end; end; function WriteSlices (f: integer): integer; var ByteCount, SelectionSize: LongInt; i, err, SaveCS: integer; begin with info^, Info^.StackInfo^ do begin SaveCS := CurrentSlice; for i := 1 to nSlices do begin CurrentSlice := i; SelectSlice(CurrentSlice); UpdateTitleBar; ByteCount := ImageSize; if odd(PixelsPerLine) then PackLines; err := fswrite(f, ByteCount, PicBaseAddr); if odd(PixelsPerLine) then UnpackLines; if err <> 0 then leave; end; CurrentSlice := SaveCS; SelectSlice(CurrentSlice); UpdateTitleBar; WriteSlices := err; end; end; procedure WriteSelection (f: integer; sLines, sPixelsPerLine: LongInt); {Contributed by Edward J. Huff(huff@mcclb0.med.nyu.edu).} var size, offset, ByteCount, BytesDone: LongInt; src, dst: ptr; err: OSErr; begin if sPixelsPerLine > UndoBufSize then exit(WriteSelection); size := sLines * sPixelsPerLine; with info^, info^.RoiRect do begin offset := top * BytesPerRow + left; src := ptr(ord4(PicBaseAddr) + offset); BytesDone := 0; while BytesDone < size do begin ByteCount := 0; dst := UndoBuf; while ((ByteCount + sPixelsPerLine) < UndoBufSize) and (BytesDone < size) do begin BlockMove(src, dst, sPixelsPerLine); src := ptr(ord4(src) + BytesPerRow); dst := ptr(ord4(dst) + sPixelsPerLine); ByteCount := ByteCount + sPixelsPerLine; BytesDone := BytesDone + sPixelsPerLine; end; err := fswrite(f, ByteCount, UndoBuf); end; SetupUndo; {Needed for drawing roi outline} end end; procedure SaveRGBTiff(f: integer; SavingSelection: boolean); const bufsize = 12000; var i, row, pixel, count, ignore: LongInt; vstart, height, hstart, width: LongInt; buffer: packed array [0 .. bufsize] of byte; rLine, gLine, bLine: LineType; err: OSErr; begin with info^ do begin if SavingSelection then with RoiRect do begin vstart := top; height := bottom - top; hstart := left; width := right - left; end else begin vstart := 0; height := nLInes; hstart := 0; width := PixelsPerLine; end; if width > MaxLine then exit(SaveRGBTiff); ShowMeter; count := 0; for row:=0 to height - 1 do begin if (row mod 10) = 0 then UpdateMeter(((row * 100) div height), 'Saving RGB TIFF'); SelectSlice(1); GetLine(hstart, vstart + row, width, rLine); SelectSlice(2); GetLine(hstart, vstart + row, width, gLine); SelectSlice(3); GetLine(hstart, vstart + row, width, bLine); for pixel := 0 to width - 1 do begin buffer[count] := 255 - rLine[pixel]; buffer[count + 1] := 255 - gLine[pixel]; buffer[count + 2] := 255 - bLine[pixel]; count := count + 3; if count > (bufsize - 3) then begin if CheckIO(fswrite(f, count, @buffer)) <> noErr then begin exit(SaveRGBTiff); UpdateMeter(-1, ''); end; count := 0; end; end; {for} end; {for} if count > 0 then err := fswrite(f, count, @buffer); UpdateMeter(-1, ''); with StackInfo^ do begin CurrentSlice := 1; SelectSlice(CurrentSlice); end; UpdateTitleBar; end; {with} end; function SaveTiffFile (fname: str255; vnum: integer; slines, sPixelsPerLine: integer; SavingSelection: boolean): boolean; var f, err, i, width, height: integer; HdrSize, ByteCount, ctabSize, StackTiffDirSize, ImageDataSize: LongInt; TheInfo: FInfo; MCIDHeader: packed array[1..4] of byte; SaveColorMap, SaveAs24BitTiff: boolean; begin SaveTiffFile := false; SaveAs24BitTiff := false; ShowWatch; err := fsopen(fname, vNum, f); if CheckIO(err) <> 0 then exit(SaveTiffFile); with Info^ do begin SaveColorMap := (LutMode <> Grayscale) and (SaveAsWhat <> asRawData); if SaveAsWhat = SaveAsMCID then begin if SavingSelection then begin width := sPixelsPerLine; height := slines; end else begin width := PixelsPerLine; height := nLines; end; MCIDHeader[1] := (width - 1) mod 256; MCIDHeader[2] := (width - 1) div 256; MCIDHeader[3] := (height - 1) mod 256; MCIDHeader[4] := (height - 1) div 256; ByteCount := 4; err := fswrite(f, ByteCount, @MCIDHeader); end; HeaderOffset := TiffDirSize; ImageDataOffset := TiffDirSize + HeaderSize; if SaveColorMap then ctabSize := SizeOf(TiffColorMapType) else ctabSize := 0; StackTiffDirSize := 0; if SavingSelection then ImageDataSize := ord4(sLines) * sPixelsPerLine else ImageDataSize := ImageSize; if StackInfo <> nil then begin ImageDataSize := ImageSize * StackInfo^.nSlices; if SaveAsWhat <> asRawData then StackTiffDirSize := SizeOf(StackIFDType) * (StackInfo^.nSlices - 1); if (StackInfo^.StackType = rgbStack) and (StackInfo^.nSlices = 3) then begin SaveAs24BitTiff := true; ctabSize := 0; StackTiffDirSize := 0; end; end; if (SaveAsWhat <> asRawData) and (SaveAsWhat <> SaveAsMCID) then begin if SaveTiffDir(f, slines, sPixelsPerLine, SavingSelection, ctabSize, ImageDataSize) <> NoErr then begin err := fsclose(f); err := FSDelete(fname, vnum); exit(SaveTiffFile) end; err := SetFPos(f, FSFromStart, TiffDirSize); if SaveHeader(f, slines, sPixelsPerLine, vnum, fname, SavingSelection, true) <> NoErr then begin err := fsclose(f); err := FSDelete(fname, vnum); exit(SaveTiffFile) end; end; if SaveAsWhat = SaveAsMCID then KillRoi; if SaveAs24bitTiff then SaveRGBTiff(f, SavingSelection) else if SavingSelection then WriteSelection(f, sLines, sPixelsPerLine) else if StackInfo <> nil then err := WriteSlices(f) else begin ByteCount := ImageDataSize; if odd(PixelsPerLine) then PackLines; err := fswrite(f, ByteCount, PicBaseAddr); if odd(PixelsPerLine) then UnpackLines; end; if SaveAsWhat = SaveAsMCID then InvertPic; if CheckIO(err) <> 0 then begin err := fsclose(f); err := FSDelete(fname, vnum); exit(SaveTiffFile) end; if SaveAsWhat = asRawData then HdrSize := 0 else if SaveAsWhat = SaveAsMCID then begin HdrSize := 4; SaveAsWhat := asRawData; end else HdrSize := HeaderSize + TiffDirSize; if SaveColorMap then SaveTiffColorMap(f, ImageDataSize); if StackTiffDirSize > 0 then err := WriteExtraTiffIFDs(f, ImageDataSize, cTabSize); err := SetEOF(f, HdrSize + ImageDataSize + ctabSize + StackTiffDirSize); err := fsclose(f); err := GetFInfo(fname, vnum, TheInfo); if TheInfo.fdCreator <> 'Imag' then begin TheInfo.fdCreator := 'Imag'; err := SetFInfo(fname, vnum, TheInfo); end; if SaveAsWhat = asRawData then begin TheInfo.fdType := 'RawD'; err := SetFInfo(fname, vnum, TheInfo); end else if TheInfo.fdType <> 'TIFF' then begin TheInfo.fdType := 'TIFF'; err := SetFInfo(fname, vnum, TheInfo); end; err := FlushVol(nil, vNum); if not SavingSelection then begin if (PictureType <> BlankField) and (PictureType <> FrameGrabberType) and (SaveAsWhat <> asRawData) then begin PictureType := TiffFile; RemovePath(fname); TruncateString(fname, maxTitle); title := fname; vref := vnum; UpdateTitleBar; if StackInfo = nil then begin revertable := true; InvertedImage := false; end; end; end; if (SaveAsWhat <> asRawData) and (not RoiShowing) then Changes := false; end; {with} SaveTiffFile := true; end; procedure SaveAsTIFF (fname: str255; RefNum: integer; slines, sPixelsPerLine: integer; SavingSelection: boolean); var err: integer; TheInfo: FInfo; replacing, ok: boolean; name: str255; begin if info = NoInfo then exit(SaveAsTIFF); err := GetFInfo(fname, RefNum, TheInfo); case err of NoErr: with TheInfo do begin if (fdType <> 'TIFF') and (fdType <> 'PICT') and (fdType <> 'IPIC') and (fdType <> 'RawD') and (fdType <> 'PICS') then begin TypeMismatch(fname); exit(SaveAsTIFF) end; replacing := true; end; FNFerr: begin if SaveAsWhat = asRawData then err := create(fname, RefNum, 'Imag', 'RawD') else err := create(fname, RefNum, 'Imag', 'TIFF'); if CheckIO(err) <> 0 then exit(SaveAsTIFF); replacing := false; end; otherwise if CheckIO(err) <> 0 then exit(SaveAsTIFF); end; if replacing then if not RoomForFile(fname, RefNum, slines, sPixelsPerLine, SavingSelection) then exit(SaveAsTIFF); ok := SaveTiffFile(fname, RefNum, slines, sPixelsPerLine, SavingSelection); if ok then UpdateWindowsMenuItem; with info^ do if SavingSelection and Replacing and (PictureType <> BlankField) and (PictureType <> FrameGrabberType) then PictureType := Leftover; end; function SavePICTFile (fname: str255; vnum: integer; SavingSelection, NewFile: boolean): boolean; var f, err, i, v: integer; ByteCount, PICTSize: LongInt; PicH: PicHandle; fRect, frect2: rect; tPort: GrafPtr; TheInfo: FInfo; SaveInfoRec: PicInfo; HeaderSaved: boolean; SaveGDevice: GDHandle; procedure Abort; begin err := fsclose(f); if NewFile then err := FSDelete(fname, vnum); DisposeHandle(handle(PicH)); {exit(SavePICTFile)} {ppc-bug} end; begin with info^ do begin if OpPending then KillRoi; SavePICTFile := false; ShowWatch; GetPort(tPort); if SavingSelection then fRect := RoiRect else SetRect(fRect, 0, 0, PixelsPerLine, nlines); with frect do SetRect(frect2, 0, 0, right - left, bottom - top); with osPort^ do begin SaveGDevice := GetGDevice; SetGDevice(osGDevice); SetPort(GrafPtr(osPort)); pmForeColor(BlackIndex); pmBackColor(WhiteIndex); if OldSystem then begin RGBForeColor(BlackRGB); RGBBackColor(WhiteRGB); end; ClipRect(PicRect); LoadLUT(cTable); PicH := OpenPicture(fRect2); CopyBits(BitMapHandle(PortPixMap)^^, BitMapHandle(PortPixMap)^^, frect, frect2, SrcCopy, nil); ClosePicture; pmForeColor(ForegroundIndex); pmBackColor(BackgroundIndex); end; SetPort(tPort); SetGDevice(SaveGDevice); PICTSize := GetHandleSize(handle(PicH)); if PICTSize <= 10 then begin PutError('Sorry, but there is not enough memory available to save this PICT file. Try closing some windows, or save as TIFF.'); if NewFile then err := FSDelete(fname, vnum); DisposeHandle(handle(PicH)); exit(SavePICTFile) end; err := fsopen(fname, vnum, f); err := SetFPos(f, FSFromStart, 0); SaveInfoRec := Info^; if (LutMode = GrayScale) or (LutMode = CustomGrayScale) then begin nColors := 256; ColorStart := 0; ColorEnd := 255; LUTMode := Grayscale; IdentityFunction := true; end; HeaderSaved := SaveHeader(f, 0, 0, vnum, fname, SavingSelection, false) = 0; Info^ := SaveInfoRec; if not HeaderSaved then begin abort; exit(SavePICTFile) end; err := fswrite(f, PICTSize, pointer(PicH^)); if CheckIO(err) <> 0 then begin abort; exit(SavePICTFile) end; DisposeHandle(handle(PicH)); ByteCount := PICTSize + HeaderSize; err := SetEOF(f, ByteCount); err := fsclose(f); err := GetFInfo(fname, vnum, TheInfo); if TheInfo.fdCreator <> 'Imag' then begin TheInfo.fdCreator := 'Imag'; err := SetFInfo(fname, vnum, TheInfo); end; if TheInfo.fdType <> 'PICT' then begin TheInfo.fdType := 'PICT'; err := SetFInfo(fname, vnum, TheInfo); end; err := FlushVol(nil, vnum); if not SavingSelection then begin if (PictureType <> BlankField) and (PictureType <> FrameGrabberType) and (PictureType <> NullPicture) then begin PictureType := PictFile; RemovePath(fname); TruncateString(fname, maxTitle); title := fname; UpdateTitleBar; vref := vnum; revertable := true; InvertedImage := false; end; Changes := false; end; end; {with} SavePICTFile := true; end; procedure SaveAsPICT (fname: str255; RefNum: integer; SavingSelection: boolean); var f, err, i: integer; where: Point; TheInfo: FInfo; replacing, ok: boolean; name: str255; begin err := GetFInfo(fname, RefNum, TheInfo); case err of NoErr: with TheInfo do begin if (fdType <> 'TIFF') and (fdType <> 'PICT') and (fdType <> 'IPIC') then begin TypeMismatch(fname); exit(SaveAsPICT) end; replacing := true; end; FNFerr: begin err := create(fname, RefNum, 'Imag', 'PICT'); if CheckIO(err) <> 0 then exit(SaveAsPICT); replacing := false; end; otherwise if CheckIO(err) <> 0 then exit(SaveAsPICT); end; ok := SavePICTFile(fname, RefNum, SavingSelection, not Replacing); if ok then UpdateWindowsMenuItem; with info^ do if SavingSelection and replacing and (PictureType <> BlankField) and (PictureType <> FrameGrabberType) then PictureType := Leftover; end; procedure SaveSelection (fname: str255; RefNum: integer; SaveAsSameType: boolean); var slines, spixelsPerLine: integer; begin if info = NoInfo then exit(SaveSelection); if NoSelection or NotRectangular or NotInBounds then exit(SaveSelection); if OpPending then KillRoi; with info^ do begin with RoiRect do begin sPixelsPerLine := right - left; slines := bottom - top; end; if (PictureType = PictFile) and SaveAsSameType and (SaveAsWhat <> asRawData) then SaveAsPICT(fname, RefNum, true) else SaveAsTIFF(fname, RefNum, sLines, sPixelsPerLine, true); end; end; procedure SaveAsText (fname: str255; RefNum: integer); var err, f: integer; TheInfo: FInfo; ByteCount: LongInt; begin err := GetFInfo(fname, RefNum, TheInfo); case err of NoErr: if TheInfo.fdType <> 'TEXT' then begin TypeMismatch(fname); exit(SaveAsText) end; FNFerr: begin err := create(fname, RefNum, FourCharCode(TextCreator), 'TEXT'); if CheckIO(err) <> 0 then exit(SaveAsText); end; otherwise if CheckIO(err) <> 0 then exit(SaveAsTExt) end; ShowWatch; err := fsopen(fname, RefNum, f); if CheckIO(err) <> 0 then exit(SaveAsText); ByteCount := TextBufSize; err := fswrite(f, ByteCount, ptr(TextBufP)); if CheckIO(err) <> 0 then exit(SaveAsText); err := SetEof(f, ByteCount); err := fsclose(f); err := FlushVol(nil, RefNum); if WhatsOnClip = TextOnClip then WhatsOnClip := NothingOnClip; end; procedure SaveAsPICS (fname: str255; fRefNum: integer); const rErr = 'Error Saving PICS file.'; var err: OSErr; TheInfo: FInfo; replacing: boolean; rRefNum, i, SaveCS: integer; frect: rect; PicH: array[1..MaxSlices] of PicHandle; MinFreeRequired: LongInt; SaveGDevice: GDHandle; begin with info^, Info^.StackInfo^ do begin if StackInfo = nil then begin PutError('Only Stacks can be saved in PICS format.'); SaveAsWhat := asTiff; exit(SaveAsPICS); end; if ImageSize > MinFree then MinFreeRequired := ImageSize else MinFreeRequired := MinFree; if MaxBlock < MinFreeRequired then begin PutError('Not enough memory available to save in PICS format.'); exit(SaveAsPICS); end; err := GetFInfo(fname, fRefNum, TheInfo); if err = NoErr then with TheInfo do begin if (fdType <> 'TIFF') and (fdType <> 'PICT') and (fdType <> 'PICS') then begin TypeMismatch(fname); exit(SaveAsPICS) end; err := FSDelete(fname, fRefNum); end; ShowWatch; err := SetVol(nil, fRefNum); CreateResFile(fname); if ResError <> NoErr then exit(SaveAsPICS); rRefNum := OpenResFile(fname); SaveCS := CurrentSlice; SaveGDevice := GetGDevice; SetGDevice(osGDevice); SetPort(GrafPtr(osPort)); with PicRect do SetRect(frect, 0, 0, right - left, bottom - top); ClipRect(frect); LoadLUT(ctable); pmForeColor(BlackIndex); pmBackColor(WhiteIndex); if OldSystem then begin RGBForeColor(BlackRGB); RGBBackColor(WhiteRGB); end; for i := 1 to nSlices do begin CurrentSlice := i; SelectSlice(CurrentSlice); UpdateTitleBar; PicH[i] := OpenPicture(frect); with osPort^ do CopyBits(BitMapHandle(portPixMap)^^, BitMapHandle(portPixMap)^^, PicRect, frect, SrcCopy, nil); ClosePicture; if (PicH[i] = nil) or ((PicH[i] <> nil) and (GetHandleSize(handle(PicH[i])) <= 10)) then begin PutError(rErr); leave; end; AddResource(handle(PicH[i]), 'PICT', i - 1 + 128, ''); if ResError <> NoErr then begin PutError(rErr); leave; end; WriteResource(handle(PicH[i])); ReleaseResource(handle(PicH[i])); if ResError <> NoErr then begin PutError(rErr); leave; end; end; {for} pmForeColor(ForegroundIndex); pmBackColor(BackgroundIndex); SetGDevice(SaveGDevice); CurrentSlice := SaveCS; SelectSlice(CurrentSlice); RemovePath(fname); TruncateString(fname, maxTitle); title := fname; PictureType := PicsFile; UpdateTitleBar; CloseResFile(rRefNum); if ResError <> NoErr then PutError(rErr); err := GetFInfo(fname, fRefNum, TheInfo); TheInfo.fdType := 'PICS'; TheInfo.fdCreator := 'Imag'; err := SetFInfo(fname, fRefNum, TheInfo); err := FlushVol(nil, fRefNum); UpdateWindowsMenuItem; end; {with} end; function SuggestedName: str255; var name: str255; begin case SaveAsWhat of asTiff, asPict, asMacPaint, asRawData, asPICS: begin name := info^.title; if name = 'Camera' then name := 'Untitled'; SuggestedName := name; end; AsPalette: SuggestedName := 'Palette'; AsOutline: SuggestedName := 'Outline'; end; end; function SaveAsHook (item: integer; theDialog: DialogPtr): integer; const EditTextID = 7; TiffID = 9; OutlineID = 14; var i: integer; fname: str255; NameEdited: boolean; begin if item = -1 then {Initialize} SetDlogItem(theDialog, TiffID + ord(SaveAsWhat), 1); fname := GetDString(theDialog, EditTextID); NameEdited := fname <> SuggestedName; if (item >= TiffID) and (item <= OutlineID) then begin SaveAsWhat := SaveAsWhatType(item - TiffID); if not NameEdited then begin SetDString(theDialog, EditTextID, SuggestedName); SelectdialogItemText(theDialog, EditTextID, 0, 32767); end; for i := TiffID to OutlineID do SetDlogItem(theDialog, i, 0); SetDlogItem(theDialog, item, 1); end; SaveAsHook := item; end; procedure SaveAs (name: str255; RefNum: integer); const CustomDialogID = 60; var where: Point; reply: SFReply; isSelection: boolean; kind: integer; begin if SaveAsDHookProc=nil then SaveAsDHookProc:=NewRoutineDescriptor(@SaveAsHook, uppDlgHookProcInfo, GetCurrentISA); with info^ do begin if SaveAllState = SaveAllStage2 then begin name := title; RefNum := SaveRefNum; if SaveAsWhat = AsPalette then SaveAsWhat := AsTiff; end else if (name = '') or ((RefNum = 0) and (pos(':', name) = 0)) then begin where.v := 50; where.h := 50; if (StackInfo = nil) and (SaveAsWhat = asPICS) then SaveAsWhat := asTIFF; if (StackInfo <> nil) and ((SaveAsWhat = asPICT) or (SaveAsWhat = asMacPaint)) then SaveAsWhat := asTIFF; if name = '' then name := SuggestedName; SFPPutFile(Where, 'Save as?', name, SaveAsDHookProc, reply, CustomDialogID, nil); if not reply.good then begin SaveAllState := NoSaveAll; AbortMacro; exit(SaveAs); end; with reply do begin name := fname; RefNum := vRefNum; DefaultRefNum := RefNum; end; end; if StackInfo <> nil then begin if (SaveAsWhat <> asOutline) and not ((StackInfo^.StackType = RGBStack) and (StackInfo^.nSlices = 3)) then KillRoi; SaveAllState := NoSaveAll; if not ((SaveAsWhat = asTIFF) or (SaveAsWhat = asPICS) or (SaveAsWhat = asPalette) or (SaveAsWhat = asOutline)) then begin PutError('Stacks can only be saved in TIFF or PICS format.'); SaveAsWhat := asTIFF; exit(SaveAs); end; end; isSelection := RoiShowing and (RoiType = RectRoi); if SaveAllState = SaveAllStage1 then begin SaveRefNum := RefNum; SaveAllState := SaveAllStage2; end; case SaveAsWhat of asTiff, asRawData: if isSelection then SaveSelection(name, RefNum, false) else SaveAsTIFF(name, RefNum, 0, 0, false); asPict: if isSelection then SaveAsPICT(name, RefNum, true) else SaveAsPICT(name, RefNum, false); asMacPaint: SaveAsMacPaint(name, RefNum); asPICS: SaveAsPICS(name, RefNum); AsPalette: SaveColorTable(name, RefNum); AsOutline: SaveOutline(name, RefNum); end; {case} if (SaveAsWhat = asRawData) and (SaveAllState <> SaveAllStage2) then SaveAsWhat := asTIFF; end; {with} end; procedure SaveFile; var fname: str255; size: LongInt; ok: boolean; begin if CurrentWindow = ResultsKind then begin Export('', 0); exit(SaveFile); end; if CurrentWindow = TextKind then begin SaveText; exit(SaveFile); end; if OpPending then KillRoi; with Info^ do begin fname := title; size := 0; if PictureType = TiffFile then ok := SaveTiffFile(fname, vref, 0, 0, false) else if PictureType = PictFile then ok := SavePICTFile(fname, vref, false, false) else SaveAs('', 0); end; end; function SaveChanges: integer; const yesID = 1; noID = 2; cancelID = 3; var id: integer; reply: SFReply; begin id := 0; if info^.changes then with info^ do begin if CommandPeriod or MakingStack or (macro and ((MacroCommand = DisposeC) or (MacroCommand = DisposeAllC))) then begin SaveChanges := ok; exit(SaveChanges); end; ParamText(title, '', '', ''); InitCursor; id := alert(600, nil); if id = yesID then begin SaveFile; InitCursor; end; {if yes} end; {if changes} if (id = cancelID) or ((id = yesID) and (info^.changes)) then SaveChanges := cancel else SaveChanges := ok; end; function CloseAWindow (WhichWindow: WindowPtr): integer; var i, kind, n: integer; TempInfo: InfoPtr; TempTextInfo: TextInfoPtr; SizeStr, str: str255; wp: ^WindowPtr; pcrect: rect; begin if WhichWindow = nil then exit(CloseAWindow); kind := WindowPeek(WhichWindow)^.WindowKind; CloseAWindow := ok; if WhichWindow = VideoControl then begin DisposeDialog(VideoControl); VideoControl := nil; exit(CloseAWindow); end; case kind of PicKind: begin Info := pointer(WindowPeek(WhichWindow)^.RefCon); with Info^ do begin if PicNum = 0 then begin beep; exit(CloseAWindow); end; if SaveChanges = cancel then begin CloseAWindow := cancel; exit(CloseAWindow) end; DeleteMenuItem(WindowsMenuH, PicNum + WindowsMenuItems + nTextWindows); for i := PicNum to nPics - 1 do begin PicWindow[i] := PicWindow[i + 1]; TempInfo := pointer(WindowPeek(PicWindow[i])^.RefCon); TempInfo^.PicNum := i end; if PictureType = BlankField then BlankFieldInfo := nil; if (PictureType = FrameGrabberType) and (FrameGrabber = QTvdig) then CloseVdig; if StackInfo <> nil then begin with StackInfo^ do for i := 1 to nSlices do DisposeHandle(PicBaseH[i]); DisposePtr(pointer(StackInfo)); end else begin if not MakingStack then DisposeHandle(PicBaseHandle); end; DisposeWindow(WhichWindow); CloseCPort(osPort); DisposePtr(ptr(osPort)); DisposeRgn(roiRgn); if DataH <> nil then DisposeHandle(DataH); nPics := nPics - 1; OpPending := false; isInsertionPoint := false; DisposePtr(pointer(Info)); Info := NoInfo; if (nPics = 0) and (not finished) then with info^ do begin LoadLUT(info^.cTable); if (LutMode = GrayScale) or (LutMode = CustomGrayScale) then DrawMap; end; PicLeft := PicLeftBase; PicTop := PicTopBase; end; end; {PicKind} HistoKind: begin DisposeWindow(HistoWindow); HistoWindow := nil; ContinuousHistogram := false; end; ProfilePlotKind, CalibrationPlotKind: begin DisposeWindow(PlotWindow); PlotWindow := nil; KillPicture(PlotPICT); PlotPICT := nil; end; ResultsKind: begin DisposeWindow(ResultsWindow); ResultsWindow := nil; TEDispose(ListTE); end; TextKind: begin TextInfo := TextInfoPtr(WindowPeek(WhichWindow)^.RefCon); if TextInfo <> nil then with TextInfo^ do begin if SaveTextChanges = cancel then begin CloseAWindow := cancel; exit(CloseAWindow) end; DisposeWindow(TextWindowPtr); DeleteMenuItem(WindowsMenuH, WindowsMenuItems - 1 + WindowNum); TEDispose(TextTE); DisposePtr(ptr(TextInfo)); TextInfo := nil; for i := WindowNum to nTextWindows - 1 do begin TextWindow[i] := TextWindow[i + 1]; TempTextInfo := pointer(WindowPeek(TextWindow[i])^.RefCon); TempTextInfo^.WindowNum := i end; nTextWindows := nTextWindows - 1; end; end; PasteControlKind: begin GetWindowRect(PasteControl, pcrect); with pcrect do begin PasteControlLeft := left; PasteControlTop := top; end; DisposeWindow(PasteControl); PasteControl := nil; wp := pointer(GhostWindow); wp^ := nil; end; otherwise ; end; {case} end; procedure DoClose; var ignore: integer; fwptr: WindowPtr; kind: integer; begin fwptr := FrontWindow; if fwptr <> nil then begin if fwptr = VideoControl then begin DisposeDialog(VideoControl); VideoControl := nil; exit(DoClose); end; kind := WindowPeek(fwptr)^.WindowKind; if (kind = PicKind) or (kind = ProfilePlotKind) or (kind = CalibrationPlotKind) or (kind = HistoKind) or (Kind = PasteControlKind) or (Kind = ResultsKind) or (Kind = TextKind) then ignore := CloseAWindow(fwptr); end; end; procedure Read4BitTIFF (f: integer); var vloc, hloc, i: integer; ByteCount, count: LongInt; err: OSErr; UnpackedLine, PackedLine: LineType; begin with info^ do begin if PixelsPerLine > MaxLine then exit(Read4BitTIFF); ByteCount := (PixelsPerLine + 1) div 2; for vloc := 0 to nLines - 1 do begin err := FSRead(f, ByteCount, @PackedLine); i := 0; for hloc := 0 to PixelsPerLine - 1 do if odd(hloc) then begin UnpackedLine[hloc] := bsl(band(PackedLine[i], $F), 4); i := i + 1; end else UnpackedLine[hloc] := band(PackedLine[i], $F0); PutLine(0, vloc, PixelsPerLine, UnpackedLine); end; end; {with} end; {$POP} procedure CheckFileSize(f:integer; var size: LongInt; offset: LongInt); {Check to make sure we don't read past the end of file.} var FileSize: LongInt; err: OSErr; begin err := GetEof(f, FileSize); if (offset + size) > FileSize then begin size := FileSize - offset; if size < 0 then size := 0; end; end; procedure ReadStackSlices (f, nExtraImages: integer; var table: TiffIFDTable); var i, err, SaveCS: integer; h: handle; DataSize: LongInt; PartialStack: boolean; begin ShowMessage(CmdPeriodToStop); PartialStack := false; with info^ do begin StackInfo := StackInfoPtr(NewPtr(SizeOf(StackInfoRec))); if StackInfo = nil then exit(ReadStackSlices); end; with info^, info^.StackInfo^ do begin nSlices := nExtraImages + 1; CurrentSlice := TempStackInfo.CurrentSlice; if (CurrentSlice < 1) or (CurrentSlice > nSlices) then CurrentSlice := 1; SliceSpacing := TempStackInfo.SliceSpacing; FrameInterval := TempStackInfo.FrameInterval; StackType := TempStackInfo.StackType; SaveCS := CurrentSlice; PicBaseH[1] := PicBaseHandle; revertable := false; for i := 2 to nSlices do begin h := GetBigHandle(PixMapSize); if h = nil then begin nSlices := i - 1; PutError(concat('Not enough memory to open all ', long2str(nExtraImages + 1), ' slices in the stack.')); PartialStack := true; leave; end; PicBaseH[i] := h; CurrentSlice := i; SelectSlice(i); UpdateTitleBar; DataSize := ImageSize; err := SetFPos(f, fsFromStart, table[i - 1].offset); CheckFileSize(f, DataSize, table[i - 1].offset); if DataSize > 0 then err := fsread(f, DataSize, h^); if odd(PixelsPerLine) then UnpackLines; if InvertedImage then InvertPic; UpdatePicWindow; if CommandPeriod then begin beep; if i < nSlices then PartialStack := true; nSlices := i; wait(60); leave; end; end; {for} CurrentSlice := SaveCS; if CurrentSlice > nSlices then CurrentSlice := 1; SelectSlice(CurrentSlice); if PartialStack then begin vref := 0; PictureType := NewPicture; title := concat(title, '@'); end; UpdateTitleBar; UpdateWindowsMenuItem; end; end; procedure OpenStack (f: integer); var table: TiffIFDTable; i, nExtraImages: integer; where: LongInt; begin nExtraImages := TempStackInfo.nSlices - 1; with info^ do begin where := ImageDataOffset; for i := 1 to nExtraImages do with table[i] do begin iWidth := PixelsPerLine; iHeight := nLines; where := where + ImageSize; Offset := where; invert := false; end; ReadStackSlices(f, nExtraImages, table); end; end; procedure OpenExtraTiffImages (f: integer; NextTiffIFD: LongInt); var table: TiffIFDTable; TiffInfo: TiffInfoRec; i, nExtraImages: integer; AllSameSize: boolean; begin nExtraImages := 0; repeat if not OpenTiffDirectory(f, NextTiffIFD, TiffInfo, false) then exit(OpenExtraTiffImages); nExtraImages := nExtraImages + 1; with TiffInfo, table[nExtraImages] do begin iWidth := width; iHeight := height; Offset := OffsetToData; invert := ZeroIsBlack; NextTiffIFD := NextIFD; end; until (NextTiffIFD = 0) or (nExtraImages = MaxSlices); AllSameSize := true; with info^ do begin for i := 1 to nExtraImages do AllSameSize := AllSameSize and (PixelsPerLine = table[i].iWidth) and (nLines = table[i].iHeight); if AllSameSize and not odd(PixelsPerLine) then ReadStackSlices(f, nExtraImages, table); end; end; procedure OpenRGBTiff(f: integer); const bufsize = 12000; var i, row, pixel, rgbPixel, ignore, SaveRow: integer; NextUpdate, count: LongInt; buffer: packed array [0 .. bufsize] of byte; rLine, gLine, bLine: LineType; err: OSErr; MaskRect: rect; begin with info^ do begin if PixelsPerLine > MaxLine then exit(OpenRGBTiff); if not MakeStackFromWindow then exit(OpenRGBTiff); if not AddSlice(false) then begin info^.changes := false; ignore := CloseAWindow(info^.wptr); exit(OpenRGBTiff); end; if not AddSlice(false) then begin info^.changes := false; ignore := CloseAWindow(info^.wptr); exit(OpenRGBTiff); end; SaveRow:=0; NextUpdate:=TickCount+6; err := SetFPos(f, fsFromStart, ImageDataOffset); count := 0; for row:=0 to nLines - 1 do begin for pixel := 0 to PixelsPerLine - 1 do begin if count <= 0 then begin count := bufsize; err := fsread(f, count, @buffer); if err <> -39 then {eof error} if CheckIO(err) <> noErr then exit(OpenRGBTiff); rgbPixel := 0; end; rLine[pixel] := 255 - buffer[rgbPixel]; gLine[pixel] := 255 - buffer[rgbPixel + 1]; bLine[pixel] := 255 - buffer[rgbPixel + 2]; rgbPixel := rgbPixel + 3; count := count - 3; end; SelectSlice(1); PutLine(0, row, PixelsPerLine, rLine); if TickCount>=NextUpdate then begin SetRect(MaskRect, 0, SaveRow, PixelsPerLine, row+1); UpdateScreen(MaskRect); SaveRow:=row + 1; NextUpdate:=TickCount+6; end; SelectSlice(2); PutLine(0, row, PixelsPerLine, gLine); SelectSlice(3); PutLine(0, row, PixelsPerLine, bLine); end; {for} with StackInfo^ do begin CurrentSlice := 1; SelectSlice(CurrentSlice); StackType := rgbStack; end; SetRect(MaskRect, 0, SaveRow, PixelsPerLine, nLines); UpdateScreen(MaskRect); UpdateTitleBar; ResetGrayMap; OpeningRGB := true; end; {with} end; function OpenFile (fname: str255; vnum: integer): boolean; var ticks, ByteCount, i, DataSize, NextTiffIFD: LongInt; err: OSErr; f: integer; line, pixel: integer; iptr, p: ptr; SaveInfo: InfoPtr; TiffInfo: TiffInfoRec; isRGBTiff: boolean; begin OpenFile := false; ShowWatch; err := fsopen(fname, vNum, f); SaveInfo := Info; iptr := NewPtr(SizeOf(PicInfo)); if iptr = nil then begin PutMemoryAlert; err := fsclose(f); exit(OpenFile) end; Info := pointer(iptr); CloneInfo(SaveInfo^, Info^); with Info^ do begin ColorMapOffset := 0; if not OpenHeader(f, fname, vnum, TiffInfo) then begin DisposePtr(iptr); err := fsclose(f); Info := SaveInfo; exit(OpenFile) end; if WhatToOpen = OpenTIFF then begin NextTiffIFD := TiffInfo.NextIFD; isRGBTiff := TiffInfo.SamplesPerPixel = 3; end else begin NextTiffIFD := 0; isRGBTiff := false; end; p := GetImageMemory(SaveInfo); if p = nil then begin err := fsclose(f); exit(OpenFile) end; PicBaseAddr := p; MakeNewWindow(fname); err := SetFPos(f, fsFromStart, ImageDataOffset); if PictureType = FourBitTIFF then Read4BitTIFF(f) else if not isRGBTiff then begin DataSize := nlines * PixelsPerLine; CheckFileSize(f, DataSize, ImageDataOffset); if DataSize > 0 then err := fsread(f, DataSize, PicBaseAddr); if CheckIO(err) <> NoErr then begin err := fsclose(f); exit(OpenFile) end; end; if odd(PixelsPerLine) and (PictureType <> FourBitTiff) then UnpackLines; if (PictureType = Imported) and (ImportInvert or (WhatToImport = ImportMCID)) then InvertedImage := true; if InvertedImage then InvertPic; if PictureType = FourBitTIFF then PictureType := imported; if (ColorMapOffset > 0) and (fileVersion = 0) then begin FixColors; {Fix colors, if necessary, of imported color TIFF files.} WhatToUndo := NothingToUndo; end; vref := vnum; if PixMapSize > UndoBufSize then PutWarning; revertable := true; end; {with} if isRGBTiff then OpenRGBTiff(f) else if TempStackInfo.nSlices > 0 then OpenStack(f) else if NextTiffIFD > 0 then OpenExtraTiffImages(f, NextTiffIFD); err := fsclose(f); OpenFile := true; end; {$PUSH} {$D-} procedure ScaleToEightBits (f: integer); type PixelLUTType = packed array[0..65535] of byte; PixelLUTPtr = ^PixelLUTType; IntLineType = array[0..MaxLine] of integer; var line: LineType; i, j, value, LineSize, offset: LongInt; ScaleFactor: extended; hloc, vloc, wwidth, wheight, IntValue, SaveBytesPerRow: integer; PixelLUT: PixelLUTPtr; str1, str2: str255; err: integer; aLine: IntLineType; LinesPerUpdate: integer; procedure reset; var DataSize, SliceOffset: LongInt; p: ptr; begin with info^ do begin if StackInfo <> nil then SliceOffset := ImageSize * 2 * (StackInfo^.CurrentSlice - 1) else SliceOffset := 0; err := SetFPos(f, fsFromStart, ImageDataOffset + SliceOffset); if DataH <> nil then begin if offset = -1 then begin hlock(DataH); DataSize := ImageSize * 2; CheckFileSize(f, DataSize, ImageDataOffset); if DataSize > 0 then err := fsread(f, DataSize, DataH^); end; offset := 0 end; end; end; procedure GetIntLine (var line: IntLineType); type atype = packed array[1..2] of char; var p: ptr; a: atype; c: char; i: integer; begin with info^ do begin if DataH <> nil then begin p := ptr(ord4(DataH^) + offset); if (offset + LineSize) <= (PixMapSize * 2) then BlockMove(p, @line, LineSize); offset := offset + LineSize; end else err := fsread(f, LineSize, @line); if LittleEndian then for i := 0 to LineSize div 2 - 1 do begin a := atype(line[i]); c := a[1]; a[1] := a[2]; a[2] := c; line[i] := integer(a) end; end; end; procedure FindMinAndMax; var vloc, hloc: integer; value: LongInt; begin with info^ do begin AbsoluteMin := 999999; AbsoluteMax := -999999; for vloc := 0 to nlines - 1 do begin if (vloc mod LinesPerUpdate) = 0 then ShowAnimatedWatch; GetIntLine(aLine); for hloc := 0 to PixelsPerLine - 1 do begin value := aLine[hloc]; if (DataType = SixteenBitsUnsigned) and (value < 0) then value := value + 65536; if value > AbsoluteMax then AbsoluteMax := value; if value < AbsoluteMin then begin if ImportingDicom then begin if value <> -32767 then AbsoluteMin := value end else AbsoluteMin := value; end; {value <AbsoluteMin} end {for hloc:=} end;{for vloc := } if (CurrentMin = 0) and (CurrentMax = 0) then begin CurrentMin := AbsoluteMin; CurrentMax := AbsoluteMax; end; reset; end; {with} end; begin with info^ do begin PixelLUT := PixelLUTPtr(NewPtr(SizeOf(PixelLUTType))); if PixelLUT = nil then begin if DataH <> nil then begin DisposeHandle(DataH); DataH := nil end; PutError('Not enough memory to do 16 to 8-bit scaling.'); AbortMacro; exit(ScaleToEightBits); end; offset := -1; reset; LineSize := PixelsPerLine * 2; LinesPerUpdate := 40000 div LineSize; if (AbsoluteMin = 0) and (AbsoluteMax = 0) then FindMinAndMax; str1 := concat('min=', long2str(CurrentMin), ' (', long2str(AbsoluteMin), ')', crStr, 'max=', long2str(CurrentMax), ' (', long2str(AbsoluteMax), ')'); ScaleFactor := 253.0 / (CurrentMax - CurrentMin); RealToString(ScaleFactor, 1, 4, str2); ShowMessage(concat(str1, crStr, 'scale factor= ', str2)); j := 0; for i := CurrentMin to CurrentMax do begin PixelLUT^[j] := round((i - CurrentMin) * ScaleFactor + 1); j := j + 1; end; for vloc := 0 to nlines - 1 do begin if (vloc mod LinesPerUpdate) = 0 then ShowAnimatedWatch; GetIntLine(aLine); for hloc := 0 to PixelsPerLine - 1 do begin value := aLine[hloc]; if (DataType = SixteenBitsUnsigned) and (value < 0) then value := value + 65536; if value < CurrentMin then value := CurrentMin; if value > CurrentMax then value := CurrentMax; line[hloc] := PixelLUT^[value - CurrentMin]; i := i + 1; end; PutLine(0, vloc, PixelsPerLine, line); end; if fit = StraightLine then begin nCoefficients := 2; coefficient[2] := (CurrentMin - CurrentMax) / 253.0; coefficient[1] := CurrentMax - coefficient[2]; nKnownValues := 0; ZeroClip := false; UpdateTitleBar; end; DisposePtr(ptr(PixelLUT)); if DataH <> nil then begin DisposeHandle(DataH); DataH := nil end; end; {with} end; procedure RescaleToEightBits; var range: LongInt; err: OSErr; f: integer; begin with info^ do begin ShowWatch; KillRoi; DisableDensitySlice; err := fsopen(title, vref, f); if CheckIO(err) <> 0 then exit(RescaleToEightBits); range := CurrentMax - CurrentMin; if ColorStart > 0 then CurrentMax := CurrentMax - round((ColorStart / 255.0) * range) else CurrentMax := AbsoluteMax; if ColorEnd < 255 then CurrentMin := CurrentMin + round(((255 - ColorEnd) / 255.0) * range) else CurrentMin := AbsoluteMin; ScaleToEightBits(f); err := fsclose(f); InvertPic; UpdatePicWindow; ResetMap; if fit <> uncalibrated then GenerateValues; end; end; procedure Import16BitSlices (f: integer); var i, err: integer; h: handle; DataSize, nImages, MaxImages, FileSize: LongInt; begin with info^ do begin nImages := ImportCustomSlices; err := GetEof(f, FileSize); MaxImages := (FileSize - ImportCustomOffset) div (ImageSize * 2); if nImages > MaxImages then nImages := MaxImages; if nImages < 2 then exit(Import16BitSlices); ShowMessage(CmdPeriodToStop); StackInfo := StackInfoPtr(NewPtr(SizeOf(StackInfoRec))); if StackInfo = nil then exit(Import16BitSlices); end; {with} with info^, info^.StackInfo^ do begin nSlices := nImages; SliceSpacing := 0.0; FrameInterval := 0.0; StackType := VolumeStack; PicBaseH[1] := PicBaseHandle; revertable := false; for i := 2 to nSlices do begin h := NewHandle(PixMapSize); if h = nil then begin nSlices := i - 1; leave; end; PicBaseH[i] := h; CurrentSlice := i; SelectSlice(i); UpdateTitleBar; DataSize := ImageSize; AbsoluteMin := 0; AbsoluteMax := 0; CurrentMin := 0; CurrentMax := 0; if not ImportAutoScale then begin if ((ImportMax - ImportMin) > 65536.0) or (ImportMin > ImportMax) then begin ImportMin := 0.0; ImportMax := 255; end; CurrentMin := round(ImportMin); CurrentMax := round(ImportMax); end; ScaleToEightBits(f); InvertPic; UpdatePicWindow; if CommandPeriod then begin beep; nSlices := i; wait(60); leave; end; end; {for} if (MaxBlock < MinFree) and (nSlices > 1) then begin repeat DisposeHandle(PicBaseH[nSlices]); nSlices := nSlices - 1; until (MaxBlock > MinFree) or (nSlices = 1); PutError(concat('Not enough memory to open all ', long2str(nImages), ' slices in the stack.')); end; CurrentSlice := 1; SelectSlice(CurrentSlice); if ImportCalibrate and ImportAutoScale then begin RemoveDensityCalibration; ImportCalibrate := false; end; UpdateTitleBar; UpdateWindowsMenuItem; end; end; function Import16BitFile (fname: str255; vnum: integer): boolean; var ticks, ByteCount, i: LongInt; err: OSErr; f: integer; line, pixel: integer; begin Import16BitFile := false; if ImportCustomWidth > MaxLine then exit(Import16BitFile); if not NewPicWindow(fname, ImportCustomWidth, ImportCustomHeight) then exit(Import16BitFile); ShowWatch; err := fsopen(fname, vNum, f); with info^ do begin PictureType := imported; ImageDataOffset := ImportCustomOffset; DataType := ImportCustomDepth; vref := vnum; AbsoluteMin := 0; AbsoluteMax := 0; CurrentMin := 0; CurrentMax := 0; LittleEndian := ImportSwapBytes; if ImportCalibrate then begin fit := StraightLine; nCoefficients := 2; coefficient[1] := 0.0; {ScaleToEightBits changes these coefficient} coefficient[2] := 1.0; end else RemoveDensityCalibration; if not ImportAutoScale then begin if ((ImportMax - ImportMin) > 65536.0) or (ImportMin > ImportMax) then begin ImportMin := 0.0; ImportMax := 255; end; CurrentMin := round(ImportMin); CurrentMax := round(ImportMax); end; DataH := GetBigHandle(PixMapSize * 2); ScaleToEightBits(f); if ImportCustomSlices > 1 then Import16BitSlices(f); err := fsclose(f); InvertPic; if PixMapSize > UndoBufSize then PutWarning; revertable := false; end; {with} Import16BitFile := true; end; procedure InitPictBuffer (howBig: LongInt); begin repeat PictBuffer := NewPtr(howBig); if PictBuffer = nil then howBig := howBig div 2; until PictBuffer <> nil; DisposePtr(PictBuffer); PictBuffer := NewPtr(howBig div 2); end; procedure FillPictBuffer; var count: LongInt; err: OSErr; begin count := GetPtrSize(PictBuffer); if not fitsInPictBuffer then begin err := FSRead(PictF, count, PictBuffer); if err <> NoErr then PictReadErr := true; end; bytesInPictBuffer := count; curPictBufPtr := PictBuffer; end; procedure GetPICTData (dataPtr: Ptr; byteCount: Integer); {Input picture spooler routine taken from Apple's PICTViewer example program.} var count: LongInt; anErr: OSErr; begin count := byteCount; repeat if bytesInPictBuffer >= count then begin BlockMove(curPictBufPtr, dataPtr, count); curPictBufPtr := Ptr(Ord4(curPictBufPtr) + count); bytesInPictBuffer := bytesInPictBuffer - count; count := 0; end else begin {Not enough in buffer} if bytesInPictBuffer > 0 then begin BlockMove(curPictBufPtr, dataPtr, bytesInPictBuffer); dataPtr := Ptr(Ord4(dataPtr) + bytesInPictBuffer); count := count - bytesInPictBuffer; end; FillPictBuffer; end; until count = 0; end; procedure BitInfo (var srcBits: PixMap; var srcRect, dstRect: rect; mode: integer; maskRgn: rgnHandle); var i, size: integer; begin if BitInfoCount = 0 then begin PictSrcRect := srcRect; if srcBits.rowBytes < 0 then with srcBits.pmTable^^ do begin {Make sure it is a PixMap.} size := ctSize; if size > 255 then size := 255; if size > 0 then begin BitInfoCount := BitInfoCount + 1; if not UseExistingLUT then with info^ do begin for i := 0 to size do cTable[i].rgb := ctTable[i].rgb; LutMode := ColorLut; SetupPseudocolor; end; end; end; {with} end; end; procedure GetLUTFromPict (thePict: PicHandle); {Refer to "Screen Dump FKEY for Color Picts", February 1988 MacTutor.} type myPicData = record p: Picture; ID: integer end; myPicPtr = ^myPicData; myPicHdl = ^myPicPtr; var tempProcs: CQDProcs; SavePort: GrafPtr; err: osErr; TempPort: CGrafPort; limbo: rect; xxscale, yyscale: extended; begin GetPort(SavePort); OpenCPort(@TempPort); SetStdCProcs(tempProcs); tempProcs.bitsProc := BitInfoProc; tempProcs.getPicProc := GetPICTDataProc; PictSrcRect := thePict^^.picFrame; BitInfoCount := 0; TempPort.grafProcs := @tempProcs; err := SetFPos(PictF, fsFromStart, 512 + SizeOf(Picture)); FillPictBuffer; limbo := thePict^^.picFrame; OffsetRect(limbo, 10000, 10000); if not PictReadErr then DrawPicture(thePict, limbo); CloseCPort(@TempPort); SetPort(SavePort); with info^, PictSrcRect do begin LoadLUT(cTable); xxScale := (right - left) / PixelsPerLine; yyScale := (bottom - top) / nLines; if (xxScale > 1.0) and ((PixelsPerLine * xxScale) <= MaxLine) and ((xxScale - yyScale) < 0.1) then begin PixelsPerLine := right - left; nLines := bottom - top; end; end; {with} end; function OpenPict;{(fname:str255; vnum:integer; Reverting:boolean):boolean} var err: OSErr; i: integer; iptr, p: ptr; PictSize, HowBig: LongInt; thePict: PicHandle; tPort: GrafPtr; tempProcs: CQDProcs; SaveProcsPtr: QDProcsPtr; SaveInfo: InfoPtr; SaveGDevice: GDHandle; TiffInfo: TiffInfoRec; procedure Abort; begin if not reverting then begin DisposePtr(pointer(Info)); Info := SaveInfo; LoadLUT(info^.cTable); end; if thePict <> nil then DisposeHandle(handle(thePict)); if PictF <> 0 then err := fsclose(PictF); {exit(OpenPict);} {ppc-bug} end; begin if BitInfoProc=nil then BitInfoProc:=NewRoutineDescriptor(@BitInfo, uppQDBitsProcInfo, GetCurrentISA); if GetPictDataProc=nil then GetPictDataProc:=NewRoutineDescriptor(@GetPictData, uppQDGetPicProcInfo, GetCurrentISA); PictF := 0; thePict := nil; OpenPict := false; PictReadErr := false; ShowWatch; SaveInfo := Info; err := fsopen(fname, vNum, PictF); if CheckIO(err) <> 0 then begin Abort; exit(OpenPict) end; if not Reverting then begin iptr := NewPtr(SizeOf(PicInfo)); if iptr = nil then begin PutMemoryAlert; err := fsclose(PictF); exit(OpenPict) end; Info := pointer(iptr); CloneInfo(SaveInfo^, Info^); end; with Info^ do begin err := GetEof(PictF, PictSize); if CheckIO(err) <> 0 then begin Abort; exit(OpenPict) end; PictSize := PictSize - 512; if PictSize <= 0 then begin Abort; exit(OpenPict) end; WhatToOpen := OpenPICT2; if not OpenHeader(PictF, fname, vnum, TiffInfo) then begin Abort; exit(OpenPict) end; thePict := PicHandle(NewHandle(SizeOf(Picture))); if thePict = nil then begin Abort; exit(OpenPict); end; err := SetFPos(PictF, fsFromStart, 512); if CheckIO(err) <> 0 then begin Abort; exit(OpenPict) end; howBig := SizeOf(Picture); err := FSRead(PictF, howBig, Pointer(thePict^)); if CheckIO(err) <> 0 then begin Abort; exit(OpenPict) end; with thePict^^.PicFrame do begin nlines := bottom - top; PixelsPerLine := right - left; end; {....} err := GetEof(PictF, howBig); howBig := howBig - (512 + SizeOf(Picture)); InitPictBuffer(HowBig * 2); if GetPtrSize(PictBuffer) >= howBig then begin err := FSRead(PictF, howBig, PictBuffer); if CheckIO(err) <> NoErr then begin DisposeHandle(handle(thePict)); DisposePtr(PictBuffer); err := fsclose(PictF); exit(OpenPict) end; fitsInPictBuffer := true; end else fitsInPictBuffer := false; if (LutMode = ColorLut) or (LutMode = CustomGrayscale) or (fileVersion = 0) then GetLUTFromPict(thePict); if not Reverting then begin p := GetImageMemory(SaveInfo); if p = nil then begin DisposeHandle(handle(thePict)); DisposePtr(PictBuffer); err := fsclose(PictF); exit(OpenPict) end; PicBaseAddr := p; MakeNewWindow(fname); end; if (PixMapSize > UndoBufSize) and (not Reverting) then begin PutWarning; ShowWatch; end; if isGrayScaleLUT then ResetGrayMap; SaveGDevice := GetGDevice; SetGDevice(osGDevice); GetPort(tPort); SetPort(GrafPtr(osPort)); pmForeColor(BlackIndex); pmBackColor(WhiteIndex); RGBForeColor(BlackRGB); RGBBackColor(WhiteRGB); EraseRect(PicRect); SaveProcsPtr := pointer(osPort^.grafProcs); SetStdCProcs(tempProcs); tempProcs.getPicProc := GetPICTDataProc; osPort^.grafProcs := @TempProcs; err := SetFPos(PictF, fsFromStart, 512 + SizeOf(Picture)); FillPictBuffer; if not PictReadErr then DrawPicture(thePict, PicRect); osPort^.grafProcs := pointer(SaveProcsPtr); DisposeHandle(handle(thePict)); DisposePtr(PictBuffer); pmForeColor(ForegroundIndex); pmBackColor(BackgroundIndex); SetPort(tPort); SetGDevice(SaveGDevice); vref := vnum; PictureType := PictFile; revertable := true; end; {with} err := fsclose(PictF); SetupUndo; if not PictReadErr then OpenPict := true; end; procedure GetCLUT (thePict: PicHandle); type myPicData = record p: Picture; ID: integer end; myPicPtr = ^myPicData; myPicHdl = ^myPicPtr; var tempProcs: CQDProcs; SaveProcsPtr: QDProcsPtr; err: osErr; begin with info^ do begin SetPort(GrafPtr(osPort)); SaveProcsPtr := pointer(wptr^.grafProcs); SetStdCProcs(tempProcs); tempProcs.bitsProc := BitInfoProc; BitInfoCount := 0; osPort^.grafProcs := @tempProcs; DrawPicture(thePict, thePict^^.picFrame); osPort^.grafProcs := pointer(SaveProcsPtr); LoadLUT(cTable); end; end; function OpenPICS (name: str255; fRefNum: integer): boolean; var RefNum, picID, hOffset, vOffset, nPICS, i: integer; err: OSErr; PicH: PicHandle; h: handle; MemError, Aborted: boolean; FrameRect: rect; SaveGDevice: GDHandle; begin if BitInfoProc=nil then BitInfoProc:=NewRoutineDescriptor(@BitInfo, uppQDBitsProcInfo, GetCurrentISA); OpenPics := false; if MaxBlock < MinFree then begin PutError('Insufficient memory to open PICS file.'); exit(OpenPICS); end; ShowWatch; err := SetVol(nil, fRefNum); RefNum := OpenResFile(name); if RefNum = -1 then begin PutError('Unable to open PICS file.'); exit(OpenPICS); end; nPICS := Count1Resources('PICT'); if nPICS < 1 then begin PutError('No PICTs found.'); CloseResFile(RefNum); exit(OpenPICS); end; PicH := GetPicture(128); if PicH = nil then begin CloseResFile(RefNum); exit(OpenPICS); end; FrameRect := PicH^^.PicFrame; with FrameRect do begin hOffset := left; vOffset := top; right := right - hOffset; bottom := bottom - vOffset; left := 0; top := 0; end; with FrameRect do if not NewPicWindow(name, right - left, bottom - top) then begin CloseResFile(RefNum); exit(OpenPICS); end; with info^ do begin revertable := false; StackInfo := StackInfoPtr(NewPtr(SizeOf(StackInfoRec))); if StackInfo = nil then begin CloseResFile(RefNum); exit(OpenPICS); end; with StackInfo^ do begin SliceSpacing := 0.0; FrameInterval := 0.0; StackType := VolumeStack; nSlices := 1; CurrentSlice := 1; PicBaseH[1] := PicBaseHandle; end; end; if not UseExistingLUT then GetCLUT(picH); with info^, Info^.StackInfo^ do begin SaveGDevice := GetGDevice; SetGDevice(osGDevice); SetPort(GrafPtr(osPort)); pmBackColor(WhiteIndex); EraseRect(PicRect); DrawPicture(picH, PicRect); DisposeHandle(handle(picH)); SetGDevice(SaveGDevice); UpdatePicWindow; picID := 129; MemError := false; for i := 2 to nPICS do begin PicH := GetPicture(picID); if (PicH = nil) or (ResError <> NoErr) then Leave; h := GetBigHandle(PixMapSize); if h = nil then begin if PicH <> nil then DisposeHandle(handle(picH)); MemError := true; Leave; end; nSlices := nSlices + 1; CurrentSlice := CurrentSlice + 1; PicBaseH[CurrentSlice] := h; SelectSlice(CurrentSlice); FrameRect := PicH^^.PicFrame; with FrameRect do begin right := right - hOffset; bottom := bottom - vOffset; left := left - hOffset; top := top - vOffset; end; SetGDevice(osGDevice); EraseRect(PicRect); if not EqualRect(FrameRect, PicRect) then BlockMove(PicBaseH[CurrentSlice - 1]^, PicBaseH[CurrentSlice]^, PixMapSize); DrawPicture(picH, FrameRect); DisposeHandle(handle(picH)); SetGDevice(SaveGDevice); UpdatePicWindow; UpdateTitleBar; Aborted := CommandPeriod; if Aborted then begin beep; wait(60); Leave; end; picID := picID + 1; end; CloseResFile(RefNum); if MemError then PutError('Not enough memory to open all images in PICS file.'); CurrentSlice := 1; SelectSlice(CurrentSlice); PictureType := PicsFile; Revertable := false; UpdateTitleBar; UpdateWindowsMenuItem; if not MemError and not Aborted then OpenPICS := true; end; {with} end; {$D-} procedure OpenAll (RefNum: integer); {Opens all appropriate files in a folder. Original version contributed by Ira Rampil.} var OpenedOK: boolean; index,vRefNum: integer; name: Str255; ftype: OSType; err: OSErr; PB: CInfoPBRec; dirID,ProcID:LongInt; begin vRefNum:=0; err:=GetWDInfo(RefNum,vRefNum,dirID,ProcID); if err<>noErr then exit(OpenAll); index := 0; while true do begin index := index + 1; with PB do begin ioCompletion := nil; ioNamePtr := @name; ioVRefNum := RefNum; ioDirID:=DirID; ioFDirIndex := index; err := PBGetCatInfoSync(@PB); {ppc-bug} if err = fnfErr then exit(OpenAll); ftype := ioFlFndrInfo.fdType; end; if ftype = 'IPIC' then begin WhatToOpen := OpenImage; if not OpenFile(name, RefNum) then exit(OpenAll); end else if ftype = 'PICT' then begin if not OpenPICT(name, RefNum, false) then exit(OpenAll) end else if ftype = 'TIFF' then begin WhatToOpen := OpenTiff; if not OpenFile(name, RefNum) then exit(OpenAll); end else if ftype = 'PNTG' then if not OpenMacPaint(name, RefNum) then exit(OpenAll); if CommandPeriod or (nPics>=MaxPics) then begin beep; exit(OpenAll); end; end; {while} end; function OpenDialogHook (item: integer; theDialog: DialogPtr): integer; const OpenAllID = 11; KeepLutID = 12; var i: integer; begin if (item = -1) and UseExistingLUT then SetDlogItem(theDialog, KeepLutID, 1); if item = OpenAllID then begin OpenAllFiles := not OpenAllFiles; SetDlogItem(theDialog, OpenAllID, ord(OpenAllFiles)); end; if item = KeepLutID then begin UseExistingLUT := not UseExistingLUT; SetDlogItem(theDialog, KeepLutID, ord(UseExistingLut)); end; OpenDialogHook := item; end; function isTiffFile (fname: str255; RefNum: integer): boolean; {Returns true if the first 16-bit word of the file contains 'MM' or 'II' and the second contains 42.} var f: integer; ByteCount: LongInt; hdr: array[1..512] of integer; err: OSErr; begin err := fsopen(fname, RefNum, f); err := SetFPos(f, fsFromStart, 0); ByteCount := 4; err := fsread(f, ByteCount, @hdr); isTiffFile := ((hdr[1] = $4949) and (hdr[2] = $2A00) or (hdr[1] = $4D4D) and (hdr[2] = $002A)); err := fsclose(f); end; function DoOpen (FileName: str255; RefNum: integer): boolean; const MyDialogID = 70; var where: Point; reply: SFReply; b: boolean; TypeList: array[0..10] of OSType; FileType: OSType; OKToContinue: boolean; FinderInfo: FInfo; err: OSErr; begin if OpenDHookProc=nil then OpenDHookProc:=NewRoutineDescriptor(@OpenDialogHook, uppDlgHookProcInfo, GetCurrentISA); KillOperation; DisableDensitySlice; OpenAllFiles := false; UseExistingLUT := false; OKToContinue := false; if FileName = '' then begin where.v := 50; where.h := 50; typeList[0] := 'IPIC'; typeList[1] := 'PICT'; typeList[2] := 'TIFF'; typeList[3] := 'ICOL'; {Color Tables} typeList[4] := 'PX05'; {PixelPaint LUT} typeList[5] := 'CLUT'; {Klutz LUT} typeList[6] := 'drwC'; {Canvas LUT} typeList[7] := 'PNTG'; {MacPaint} typeList[8] := 'PICS'; typeList[9] := 'Iout'; {Outlines} typeList[10] := 'TEXT'; SFPGetFile(Where, '', nil, 11, @TypeList, OpenDHookProc, reply, MyDialogID, nil); if reply.good then with reply do begin FileName := fname; FileType := ftype; RefNum := vRefNum; DefaultRefNum := RefNum; DefaultFileName := fname; OKToContinue := true; end; if reply.good and OpenAllFiles then begin OpenAll(RefNum); exit(DoOpen); end; end else begin err := GetFInfo(FileName, RefNum, FinderInfo); FileType := FinderInfo.fdType; OKToContinue := true; end; DoOpen := OKToContinue; if OKToContinue then begin if FileType = 'IPIC' then begin WhatToOpen := OpenImage; b := OpenFile(FileName, RefNum) end else if FileType = 'PICT' then begin b := OpenPICT(FileName, RefNum, false) end else if FileType = 'TIFF' then begin WhatToOpen := OpenTIFF; b := OpenFile(FileName, RefNum) end else if FileType = 'ICOL' then OpenColorTable(FileName, RefNum) else if FileType = 'PX05' then ImportPalette('PX05', FileName, RefNum) else if FileType = 'CLUT' then ImportPalette('CLUT', FileName, RefNum) else if FileType = 'drwC' then ImportPalette('PX05', FileName, RefNum) else if FileType = 'PNTG' then b := OpenMacPaint(FileName, RefNum) etID = 17; EightBitsID = 18; SixteenBitsUnsignedID = 19; SixteenBitsSignedID = 20; SwapBytesID = 21; ImportAllID = 22; EditID = 23; CalibrateID = 24; InvertID = 25; var i: integer; procedure SetRadioButtons1; var i: integer; begin SetDlogItem(mylog, TiffID, 0); SetDlogItem(mylog, DicomID, 0); SetDlogItem(mylog, LutID, 0); SetDlogItem(mylog, TextID, 0); SetDlogItem(mylog, CustomID, 0); case WhatToImport of ImportTiff: SetDlogItem(mylog, TiffID, 1); ImportDicom: SetDlogItem(mylog, DicomID, 1); ImportLUT: SetDlogItem(mylog, LutID, 1); ImportText: SetDlogItem(mylog, TextID, 1); ImportCustom: SetDlogItem(mylog, CustomID, 1); end; end; procedure SetRadioButtons2; var i: integer; begin SetDlogItem(mylog, EightBitsID, 0); SetDlogItem(mylog, SixteenBitsUnsignedID, 0); SetDlogItem(mylog, SixteenBitsSignedID, 0); case ImportCustomDepth of EightBits: SetDlogItem(mylog, EightBitsID, 1); SixteenBitsUnsigned: SetDlogItem(mylog, SixteenBitsUnsignedID, 1); SixteenBitsSigned: SetDlogItem(mylog, SixteenBitsSignedID, 1); end; end; procedure ShowParameters; var str1, str2, str3: str255; begin NumToString(ImportCustomWidth, str1); NumToString(ImportCustomHeight, str2); NumToString(ImportCustomOffset, str3); ParamText(str1, str2, str3, ''); end; begin if item = -1 then begin {Initialize} SetRadioButtons1; SetRadioButtons2; ShowParameters; SetDlogItem(mylog, SwapBytesID, ord(ImportSwapBytes)); SetDlogItem(mylog, ImportAllID, ord(ImportAll)); SetDlogItem(mylog, InvertID, ord(ImportInvert)); SetDlogItem(mylog, CalibrateID, ord(ImportCalibrate)); end; if (item >= TiffID) and (item <= CustomID) then begin case item of TiffID: WhatToImport := ImportTiff; DicomID: WhatToImport := ImportDicom; LutID: WhatToImport := ImportLUT; TextID: WhatToImport := ImportText; CustomID: WhatToImport := ImportCustom; end; SetRadioButtons1; end; if item = EditID then begin EditImportParameters; WhatToImport := ImportCustom; SetRadioButtons1; ShowParameters; SetDlogItem(mylog, CalibrateID, ord(ImportCalibrate)); end; if (item >= EightBitsID) and (item <= SixteenBitsSignedID) then begin case item of EightBitsID: ImportCustomDepth := EightBits; SixteenBitsUnsignedID: ImportCustomDepth := SixteenBitsUnsigned; SixteenBitsSignedID: ImportCustomDepth := SixteenBitsSigned; end; SetRadioButtons2; WhatToImport := ImportCustom; SetRadioButtons1; end; if item = SwapBytesID then begin ImportSwapBytes := not ImportSwapBytes; SetDlogItem(mylog, SwapBytesID, ord(ImportSwapBytes)); WhatToImport := ImportCustom; SetRadioButtons1; end; if item = ImportAllID then begin ImportAll := not ImportAll; SetDlogItem(mylog, ImportAllID, ord(ImportAll)); end; if item = InvertID then begin ImportInvert := not ImportInvert; SetDlogItem(mylog, InvertID, ord(ImportInvert)); end; if item = CalibrateID then begin ImportCalibrate := not ImportCalibrate; SetDlogItem(mylog, CalibrateID, ord(ImportCalibrate)); WhatToImport := ImportCustom; SetRadioButtons1; end; ImportDialogHook := item; end; function ImportFile (FileName: str255; RefNum: integer): boolean; const ImportDialogID = 90; var where: Point; typeList: SFTypeList; reply: SFReply; b, ImportingTIFF, HasColorMap: boolean; begin if ImportDHookProc=nil then ImportDHookProc:=NewRoutineDescriptor(@ImportDialogHook, uppDlgHookProcInfo, GetCurrentISA); ImportFile := true; DisableDensitySlice; if not macro then begin ImportAll := false; if WhatToImport=ImportMCID then WhatToImport:=ImportTIFF; end; if FileName = '' then begin where.v := 50; where.h := 50; SFPGetFile(Where, '', nil, -1, @typeList, ImportDHookProc, reply, ImportDialogID, nil); if not reply.good then begin ImportFile := false; exit(ImportFile); end; with reply do begin FileName := fname; RefNum := vRefNum; DefaultRefNum := RefNum; DefaultFileName := fname; end; end; if isTiffFile(FileName, RefNum) and not macro and not OptionKeyWasDown then WhatToImport := ImportTiff; ImportingTIFF := WhatToImport = ImportTiff; if ImportingTIFF then if not GetTIFFParameters(FileName, RefNum, HasColorMap) then exit(ImportFile); case WhatToImport of ImportMCID: WhatToOpen := OpenImported; ImportCustom: begin if (ImportCustomDepth <> EightBits) and (ImportCustomWidth > MaxLine) then begin PutError(concat('Maximum width of imported 16-bit images is ', long2str(MaxLine), '.')); exit(ImportFile); end; WhatToOpen := OpenCustom; end; ImportDicom: begin ImportDicomImages(FileName, RefNum, ImportAll, Import16BitFile); exit(ImportFile); end ImportLUT: begin DoImportLut(FileName, RefNum); exit(ImportFile); end; ImportText: begin ImportFile := ImportTextFile(FileName, RefNum); exit(ImportFile); end; otherwise; end; if ImportAll then ImportAllFiles(RefNum) else if (WhatToOpen = OpenCustom) and (ImportCustomDepth <> EightBits) then b := Import16BitFile(FileName, RefNum) else b := OpenFile(FileName, RefNum); if macro then GenerateValues; if ImportingTIFF then WhatToImport := ImportTiff; {GetTIFFParameters may have changed it to ImportCustom.} end; procedure RevertToSaved; var fname: str255; err, f: integer; ok: boolean; size: LongInt; begin if OpPending then KillRoi; DisableDensitySlice; with Info^ do begin fname := title; SetPort(wptr); if PictureType = PICTFile then begin ok := OpenPICT(fname, vref, true); UpdatePicWindow; end else begin ShowWatch; err := fsopen(fname, vref, f); ok := true; if HeaderOffset <> -1 then ok := OpenImageHeader(f, fname, vref); if ok then begin err := SetFPos(f, fsFromStart, ImageDataOffset); size := ImageSize; CheckFileSize(f, size, ImageDataOffset); if size > 0 then err := fsread(f, size, PicBaseAddr); if odd(PixelsPerLine) then UnpackLines; if Info^.InvertedImage then InvertPic; UpdatePicWindow; end; err := fsclose(f); RoiShowing := false; end; OpPending := false; Changes := false; UpdateTitleBar; end; {with} end; procedure FindWhatToPrint; var kind: integer; WhichWindow: WindowPtr; begin WhatToPrint := NothingToPrint; WhichWindow := FrontWindow; if WhichWindow = nil then exit(FindWhatToPrint); kind := WindowPeek(WhichWindow)^.WindowKind; if (kind = PicKind) and info^.RoiShowing and measuring then kind := InfoKind; case kind of PicKind: if info^.RoiShowing then WhatToPrint := PrintSelection else WhatToPRint := PrintImage; HistoKind: WhatToPrint := PrintHistogram; ProfilePlotKind, CalibrationPlotKind: WhatToPrint := PrintPlot; InfoKind, ResultsKind: if mCount > 0 then WhatToPrint := PrintMeasurements; TextKind: WhatToPrint := PrintText; otherwise ; end; if (WhatToPrint = NothingToPRint) and (info <> NoInfo) then WhatToPrint := PrintImage; end; procedure UpdateFileMenu; var ShowItems, isSelection, notStack: boolean; i: integer; str, str2: str255; begin with info^ do begin ShowItems := Info <> NoInfo; isSelection := RoiShowing and (RoiType = RectRoi); notStack := StackInfo = nil; if OptionKeyWasDown and (CurrentKind <> TextKind) then begin SetMenuItemText(FileMenuH, CloseItem, 'Close All…'); SetMenuItemText(FileMenuH, SaveItem, 'Save All'); SetMenuItem(FileMenuH, CloseItem, ShowItems); end else begin SetMenuItemText(FileMenuH, CloseItem, 'Close…'); if isSelection and notStack and (CurrentKind <> TextKind) and (PictureType <> TiffFile) and (PictureType <> PictFile) and (CurrentKind = PicKind) then SetMenuItemText(FileMenuH, SaveItem, 'Save Selection') else SetMenuItemText(FileMenuH, SaveItem, 'Save'); SetMenuItem(FileMenuH, CloseItem, ShowItems or (CurrentKind = TextKind) or (CurrentKind = ResultsKind) or (CurrentKind = ProfilePlotKind) or (CurrentKind = CalibrationPlotKind) or (CurrentKind = HistoKind)); end; case CurrentKind of ProfilePlotKind, CalibrationPlotKind: ExportAsWhat := asPlotValues; HistoKind: ExportAsWhat := asHistogramValues; ResultsKind: ExportAsWhat := asMeasurements; PicKind: begin if (SaveAsWhat <> asPICT) then SaveAsWhat := asTiff; if (ExportAsWhat > asText) then ExportAsWhat := asRaw; end; otherwise end; if isSelection and notStack and (SaveAsWhat <> AsPalette) and (CurrentKind <> ResultsKind) and (CurrentKind <> TextKind) then SetMenuItemText(FileMenuH, SaveAsItem, 'Save Selection As…') else SetMenuItemText(FileMenuH, SaveAsItem, 'Save As…'); if isSelection and notStack and (ExportAsWhat <= AsText) then SetMenuItemText(FileMenuH, ExportItem, 'Export Selection As…') else SetMenuItemText(FileMenuH, ExportItem, 'Export…'); for i := SaveItem to SaveAsItem do SetMenuItem(FileMenuH, i, ShowItems or (CurrentKind = TextKind)); SetMenuItem(FileMenuH, ExportItem, (ShowItems or (CurrentKind = ResultsKind)) and (CurrentKind <> TextKind)); if isSelection then str := 'Duplicate Selection' else str := 'Duplicate'; SetMenuItemText(FileMenuH, DuplicateItem, str); for i := DuplicateItem to GetInfoItem do SetMenuItem(FileMenuH, i, ShowItems and (CurrentKind <> TextKind)); if DataType <> EightBits then str := 'Rescale' else str := 'Revert to Saved'; SetMenuItemText(FileMenuH, RevertItem, str); SetMenuItem(FileMenuH, RevertItem, (Revertable or (DataType <> EightBits)) and (CurrentKind <> TextKind)); SetMenuItem(FileMenuH, PlugInExportItem, ShowItems); FindWhatToPrint; case WhatToPrint of NothingToPrint: str := ''; PrintImage: str := 'Image'; PrintSelection: str := 'Selection'; PrintPlot: str := 'Plot'; PrintHistogram: str := 'Histogram'; PrintMeasurements: str := 'Results'; PrintText: str := 'Text'; end; SetMenuItemText(FileMenuH, PrintItem, concat('Print ', str, '…')); SetMenuItem(FileMenuH, PrintItem, WhatToPrint <> NothingToPrint); end; {with info^} end; procedure SaveAll; var SaveInfo: InfoPtr; i: integer; begin SaveInfo := Info; SaveAsWhat := AsTiff; SaveAllState := SaveAllStage1; for i := 1 to nPics do begin Info := pointer(WindowPeek(PicWindow[i])^.RefCon); SaveAs('', 0); if CommandPeriod or (SaveAllState = NoSaveAll) then leave; end; Info := SaveInfo; SaveAllState := NoSaveAll; end; function SuggestedExportName: str255; var name: str255; begin name := info^.title; case ExportAsWhat of asRaw, asMCID, asText: begin if name = 'Camera' then name := 'Untitled'; if ExportAsWhat = AsText then SuggestedExportName := concat(name, ' (Text)') else SuggestedExportName := name; end; AsLUT: SuggestedExportName := 'Palette'; asMeasurements: SuggestedExportName := concat(name, ' (Measurements)'); AsPlotValues: SuggestedExportName := concat(name, ' (Plot Values)'); asHistogramValues: SuggestedExportName := concat(name, ' (Histogram)'); asCoordinates: SuggestedExportName := concat(name, ' (Coordinates)'); end; end; function ExportHook (item: integer; theDialog: DialogPtr): integer; const EditTextID = 7; RawID = 9; xyCoordinatesID = 16; var i: integer; fname: str255; NameEdited: boolean; begin if item = -1 then {Initialize} SetDlogItem(theDialog, RawID + ord(ExportAsWhat), 1); fname := GetDString(theDialog, EditTextID); NameEdited := fname <> SuggestedExportName; if (item >= RawID) and (item <= xyCoordinatesID) then begin ExportAsWhat := ExportAsWhatType(item - RawID); if not NameEdited then begin SetDString(theDialog, EditTextID, SuggestedExportName); SelectdialogItemText(theDialog, EditTextID, 0, 32767); end; for i := RawID to xyCoordinatesID do SetDlogItem(theDialog, i, 0); SetDlogItem(theDialog, item, 1); end; ExportHook := item; end; procedure Export (name: str255; RefNum: integer); const CustomDialogID = 100; var where: Point; reply: SFReply; isSelection: boolean; kind: integer; SaveAsState: SaveAsWhatType; begin if ExportDHookProc=nil then ExportDHookProc:=NewRoutineDescriptor(@ExportHook, uppDlgHookProcInfo, GetCurrentISA); with info^ do begin if (name = '') or ((RefNum = 0) and (pos(':', name) = 0)) then begin where.v := 50; where.h := 50; if name = '' then name := SuggestedExportName; SFPPutFile(Where, 'Save as?', name, ExportDHookProc, reply, CustomDialogID, nil); if not reply.good then begin AbortMacro; exit(Export); end; with reply do begin name := fname; RefNum := vRefNum; DefaultRefNum := RefNum; end; end; if (Info = NoInfo) and (ExportAsWhat <= asText) then begin PutError('No image data available.'); AbortMacro; exit(Export); end; isSelection := RoiShowing and (RoiType = RectRoi); case ExportAsWhat of asRaw, asMCID: begin if ExportAsWhat = asMCID then InvertPic; SaveAsState := SaveAsWhat; if ExportAsWhat = AsRaw then SaveAsWhat := asRawData else SaveAsWhat := SaveAsMCID; if isSelection then SaveSelection(name, RefNum, false) else SaveAsTIFF(name, RefNum, 0, 0, false); SaveAsWhat := SaveAsState; end; AsText: ExportAsText(name, RefNum); AsLUT: SaveLUT(name, RefNum); asMeasurements: if mCount > 0 then ExportMeasurements(name, RefNum) else PutError('Sorry, but no measurements are available to export.'); AsPlotValues: if PlotWindow <> nil then begin kind := WindowPeek(PlotWindow)^.WindowKind; case kind of ProfilePlotKind: ConvertPlotToText; CalibrationPlotKind: ConvertCalibrationCurveToText; otherwise TextBufSize := 0; end; SaveAsText(name, RefNum); end else beep; asHistogramValues: if HistoWindow <> nil then begin ConvertHistoToText; SaveAsText(name, RefNum); end else beep; asCoordinates: ExportCoordinates(name, RefNum); otherwise beep; end; {case} if (SaveAsWhat = asRawData) and (SaveAllState <> SaveAllStage2) then SaveAsWhat := asTIFF; end; {with} end; end. 
