home *** CD-ROM | disk | FTP | other *** search
Text File | 1992-03-30 | 80.0 KB | 2,951 lines
unit File1; {Routines used by Image for implementing File Menu commands.} interface uses QuickDraw, Palettes, PrintTraps, globals, Utilities, Graphics, file2, sound, Lut; 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; procedure UpdateWindowsMenuItem (PicSize: LongInt; title: str255; PicNum: integer); procedure SaveScreen; function OpenPICS (name: str255; fRefNum: integer): boolean; implementation var OpenAllFiles, UseExistingLUT, PICTReadErr, UpdateIcons: boolean; SaveRefNum: integer; TempStackInfo: StackInfoRec; {$PUSH} {$D-} function IOCheck (err: OSerr): integer; var ErrStr, Message: str255; ignore: integer; begin if err <> 0 then begin Message := ''; case err of -34: Message := 'Disk Full'; -36: Message := 'I/O Error'; -49: Message := 'File in Use'; end; NumToString(err, ErrStr); ParamText(Message, ErrStr, '', ''); InitCursor; ignore := alert(IOErrorID, nil); macro := false; {If macro, abort it} end; IOCheck := err; end; 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; begin ByteCount := HeaderSize; err := SetFPos(f, fsFromStart, info^.HeaderOffset); err := fsread(f, ByteCount, @TempHdr); if IOCheck(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 RawSpatialScale := hRawSpatialScale; if hversion > 124 then begin ScaleMagnification := hScaleMagnification; xSpatialScale := hRawSpatialScale * ScaleMagnification; end else begin ScaleMagnification := 1.0; xSpatialScale := hRawSpatialScale; end; ySpatialScale := xSpatialScale; PixelAspectRatio := 1.0; SpatiallyCalibrated := xSpatialScale <> 0.0; end; if hversion > 140 then begin PixelAspectRatio := hPixelAspectRatio; ySpatialScale := xSpatialScale / PixelAspectRatio; end; GetUnits(hUnitsID); if ((hnCoefficients > 0) and (hfit < UncalibratedOD)) or (hfit = UncalibratedOD) then begin if (hfit = SpareFit1) or (hfit = SpareFit2) then begin DensityCalibrated := false; DrawLabels('', '', ''); end else begin fit := hfit; if hfit <> UncalibratedOD then begin nCoefficients := hnCoefficients; Coefficient := hCoeff; end; UnitOfMeasure := hUM; DensityCalibrated := true; if hversion >= 144 then ZeroClip := hZeroClip else ZeroClip := false; GenerateValues; end; end else begin DensityCalibrated := false; 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; LoopTime := hLoopTime; end; end; OpenImageHeader := true end; end; function OpenHeader (f: integer; fname: str255; vnum: integer; var NextTiffIFD: LongInt): boolean; var ByteCount, FileSize, DirOffset: LongInt; hdr: packed array[1..512] of byte; err: OSErr; TempHdr: PicHeader; TiffInfo: TiffInfoRec; 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 TempStackInfo.nSlices := 0; CurrentSlice := 1; SliceSpacing := 0.0; LoopTime := 0.0; end; NextTiffIFD := 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 := PDP11; 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 if macro then begin err := GetEof(f, FileSize); if (ImportCustomOffset + LongInt(ImportCustomWidth) * ImportCustomHeight) > FileSize then begin macro := false; OpenHeader := false; exit(OpenHeader) end; end; PixelsPerLine := ImportCustomWidth; nlines := ImportCustomHeight; PictureType := imported; HeaderOffset := -1; ImageDataOffset := ImportCustomOffset; 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) 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; if ZeroIsBlack and (PictureType <> FourBitTIFF) then PictureType := InvertedTiff; if resolution > 0.0 then begin case ResUnits of tNoUnits: GetUnits(14); {pixels} tCentimeters: GetUnits(8); tInches: GetUnits(11); end; RawSpatialScale := resolution; xSpatialScale := resolution; ySpatialScale := resolution; PixelAspectRatio := 1.0; ScaleMagnification := 1.0; SpatiallyCalibrated := true; end; ColorMapOffset := OffsetToColorMap; HeaderOffset := OffsetToImageHeader; NextTiffIFD := NextIFD; 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; 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; hRawSpatialScale := RawSpatialScale; hScaleMagnification := ScaleMagnification; hPixelAspectRatio := PixelAspectRatio; hUnitsID := ord(UnitsID) + 5; FindPoints(hp1x, hp1y, hp2x, hp2y); if not DensityCalibrated then hnCoefficients := 0 else hnCoefficients := nCoefficients; hfit := fit; hCoeff := Coefficient; hZeroClip := ZeroClip; hUM := UnitOfMeasure; hBinaryPic := BinaryPic; hSliceStart := SliceStart; hSliceEnd := SliceEnd; if StackInfo <> nil then with StackInfo^ do begin hNSlices := nSlices; hSliceSpacing := SliceSpacing; hCurrentSlice := CurrentSlice; hLoopTime := LoopTime; end else begin hNSlices := 0; hSliceSpacing := 0.0; hCurrentSlice := 0; hLoopTime := 0.0; end; ByteCount := SizeOf(TempHdr); if ByteCount <> HeaderSize then begin NumToString(ByteCount, str); PutMessage('Internal error check: header size is incorrect.'); ExitToShell; end; if SavingSelection then begin hnlines := slines; hPixelsPerLine := sPixelsPerLine; end; err := fswrite(f, ByteCount, @TempHdr); SaveHeader := IOCheck(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) + LongInt(nlines - 1) * PixelsPerLine); DstPtr := ptr(ord4(PicBaseAddr) + LongInt(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; 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: boolean; begin SaveTiffFile := false; ShowWatch; err := fsopen(fname, vNum, f); if IOCheck(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 := LongInt(slines) * sPixelsPerLine else if StackInfo <> nil then begin ImageDataSize := ImageSize * StackInfo^.nSlices; StackTiffDirSize := SizeOf(StackIFDType) * (StackInfo^.nSlices - 1) end else ImageDataSize := ImageSize; 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 SavingSelection then begin ByteCount := ImageDataSize; err := fswrite(f, ByteCount, UndoBuf); SetupUndo; {Needed for drawing roi outline} end 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 IOCheck(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 <> QuickCaptureType) and (PictureType <> ScionType) and (SaveAsWhat <> asRawData) then begin PictureType := TiffFile; title := fname; vref := vnum; if StackInfo <> nil then begin UpdateTitleBar; revertable := true; end; end; end; if SaveAsWhat <> asRawData then Changes := false; end; {with} SaveTiffFile := true; end; procedure UpdateWindowsMenuItem (PicSize: LongInt; title: str255; PicNum: integer); var str: str255; begin NumToString(PicSize div 1024, str); str := concat(title, ' ', str, 'K'); SetItem(WindowsMenuH, PicNum + WindowsMenuItems, str); end; procedure SaveAsTIFF (fname: str255; RefNum: integer; slines, sPixelsPerLine: integer; SavingSelection: boolean); var err: integer; 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') 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 IOCheck(err) <> 0 then exit(SaveAsTIFF); replacing := false; end; otherwise if IOCheck(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 with info^ do if StackInfo <> nil then UpdateWindowsMenuItem(ImageSize * StackInfo^.nSlices, title, PicNum) else UpdateWindowsMenuItem(ImageSize, title, PicNum); with info^ do if SavingSelection and Replacing and (PictureType <> BlankField) and (PictureType <> QuickCaptureType) and (PictureType <> ScionType) 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; procedure Abort; begin err := fsclose(f); if NewFile then err := FSDelete(fname, vnum); DisposHandle(handle(PicH)); exit(SavePICTFile) 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 SetPort(GrafPtr(osPort)); pmForeColor(BlackIndex); pmBackColor(WhiteIndex); if OldSystem then begin {Work around for Palette Manager bug in Systems before 6.0.5.} RGBForeColor(BlackRGB); RGBBackColor(WhiteRGB); end; ClipRect(PicRect); LoadLUT(cTable); {Restore look-up table in case it has changed.} PicH := OpenPicture(fRect2); hlock(handle(PortPixMap)); CopyBits(BitMapHandle(PortPixMap)^^, BitMapHandle(PortPixMap)^^, frect, frect2, SrcCopy, nil); hunlock(handle(PortPixMap)); ClosePicture; pmForeColor(ForegroundIndex); pmBackColor(BackgroundIndex); end; SetPort(tPort); PICTSize := GetHandleSize(handle(PicH)); if PICTSize <= 10 then begin PutMessage('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); DisposHandle(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 abort; err := fswrite(f, PICTSize, pointer(PicH^)); if IOCheck(err) <> 0 then abort; DisposHandle(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 <> QuickCaptureType) and (PictureType <> ScionType) and (PictureType <> NullPicture) then begin PictureType := PictFile; title := fname; UpdateTitleBar; vref := vnum; revertable := true; 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 IOCheck(err) <> 0 then exit(SaveAsPICT); replacing := false; end; otherwise if IOCheck(err) <> 0 then exit(SaveAsPICT); end; ok := SavePICTFile(fname, RefNum, SavingSelection, not Replacing); if ok then with info^ do UpdateWindowsMenuItem(ImageSize, title, PicNum); with info^ do if SavingSelection and replacing and (PictureType <> BlankField) and (PictureType <> QuickCaptureType) and (PictureType <> ScionType) then PictureType := Leftover; end; procedure SaveSelection (fname: str255; RefNum: integer; SaveAsSameType: boolean); var size, offset: LongInt; i, slines, spixelsPerLine, hstart, vstart: integer; src, dst: ptr; begin if NoSelection or NotRectangular or NotInBounds then exit(SaveSelection); if OpPending then KillRoi; with info^ do begin with RoiRect do begin sPixelsPerLine := right - left; if odd(sPixelsPerLine) and (left + sPixelsPerLine < PicRect.right) and (SaveAsWhat <> asRawData) then sPixelsPerLine := sPixelsPerLine + 1; slines := bottom - top; size := LongInt(slines) * sPixelsPerLine; hstart := left; vstart := top; end; if (PictureType <> PictFile) or not SaveAsSameType then begin if size > UndoBufSize then begin PutMessage('There is not enough memory available to save the selection'); exit(SaveSelection) end; offset := LongInt(vstart) * BytesPerRow + hstart; src := ptr(ord4(PicBaseAddr) + offset); dst := UndoBuf; for i := 0 to slines - 1 do begin BlockMove(src, dst, sPixelsPerLine); src := ptr(ord4(src) + BytesPerRow); dst := ptr(ord4(dst) + sPixelsPerLine); end; 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, 'MSWD', 'TEXT'); if IOCheck(err) <> 0 then exit(SaveAsText); end; otherwise if IOCheck(err) <> 0 then exit(SaveAsTExt) end; ShowWatch; err := fsopen(fname, RefNum, f); if IOCheck(err) <> 0 then exit(SaveAsText); ByteCount := TextBufSize; err := fswrite(f, ByteCount, ptr(TextBufP)); if IOCheck(err) <> 0 then exit(SaveAsText); err := SetEof(f, ByteCount); err := fsclose(f); err := FlushVol(nil, RefNum); if WhatsOnClip = TextOnClip then WhatsOnClip := Nothing; 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; begin with info^, Info^.StackInfo^ do begin if StackInfo = nil then begin PutMessage('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 PutMessage('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; 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 begin hlock(handle(portPixMap)); CopyBits(BitMapHandle(portPixMap)^^, BitMapHandle(portPixMap)^^, PicRect, frect, SrcCopy, nil); hunlock(handle(portPixMap)); end; ClosePicture; if (PicH[i] = nil) or ((PicH[i] <> nil) and (GetHandleSize(handle(PicH[i])) <= 10)) then begin PutMessage(rErr); leave; end; AddResource(handle(PicH[i]), 'PICT', i - 1 + 128, ''); if ResError <> NoErr then begin PutMessage(rErr); leave; end; WriteResource(handle(PicH[i])); ReleaseResource(handle(PicH[i])); if ResError <> NoErr then begin PutMessage(rErr); leave; end; end; {for} CurrentSlice := SaveCS; SelectSlice(CurrentSlice); title := fname; PictureType := PicsFile; UpdateTitleBar; CloseResFile(rRefNum); if ResError <> NoErr then PutMessage(rErr); err := GetFInfo(fname, fRefNum, TheInfo); TheInfo.fdType := 'PICS'; TheInfo.fdCreator := 'Imag'; err := SetFInfo(fname, fRefNum, TheInfo); err := FlushVol(nil, fRefNum); UpdateWindowsMenuItem(ImageSize, title, PicNum); pmForeColor(ForegroundIndex); pmBackColor(BackgroundIndex); end; {with} end; {$POP} 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} SetDialogItem(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); SelIText(theDialog, EditTextID, 0, 32767); end; for i := TiffID to OutlineID do SetDialogItem(theDialog, i, 0); SetDialogItem(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 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) 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, @SaveAsHook, reply, CustomDialogID, nil); if not reply.good then begin SaveAllState := NoSaveAll; macro := false; exit(SaveAs); end; with reply do begin name := fname; RefNum := vRefNum; DefaultRefNum := RefNum; end; end; if StackInfo <> nil then begin KillRoi; SaveAllState := NoSaveAll; if not ((SaveAsWhat = asTIFF) or (SaveAsWhat = asPICS) or (SaveAsWhat = asPalette)) then begin PutMessage('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 FrontWindow = ResultsWindow then begin Export('', 0); 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; SizeStr, str: str255; wp: ^WindowPtr; pcrect: rect; begin kind := WindowPeek(WhichWindow)^.WindowKind; CloseAWindow := ok; 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; DelMenuItem(WindowsMenuH, PicNum + WindowsMenuItems); 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 = QuickCaptureType then QuickCaptureInfo := nil; if PictureType = BlankField then BlankFieldInfo := nil; if PictureType = ScionType then ScionInfo := nil; if StackInfo <> nil then begin with StackInfo^ do for i := 1 to nSlices do DisposHandle(PicBaseH[i]); DisposPtr(pointer(StackInfo)); end else begin if not MakingStack then DisposHandle(PicBaseHandle); end; DisposeWindow(WhichWindow); CloseCPort(osPort); Dispose(osPort); DisposeRgn(roiRgn); nPics := nPics - 1; OpPending := false; isInsertionPoint := false; DisposPtr(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; PasteControlKind: begin GetWindowRect(PasteControl, pcrect); with pcrect do begin PasteControlLeft := left; PasteControlTop := top; end; DisposeWindow(PasteControl); PasteControl := nil; wp := pointer(GhostWindow); wp^ := nil; end; end; {case} end; procedure DoClose; var ignore: integer; fwptr: WindowPtr; kind: integer; begin fwptr := FrontWindow; kind := WindowPeek(fwptr)^.WindowKind; if (kind = PicKind) or (kind = ProfilePlotKind) or (kind = CalibrationPlotKind) or (kind = HistoKind) or (Kind = PasteControlKind) or (Kind = ResultsKind) then ignore := CloseAWindow(fwptr); 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; procedure Import16BitImage; type IntArrayType = packed array[0..5000000] of integer; IntArrayPtr = ^IntArrayType; PixelLUTType = packed array[0..65535] of Unsignedbyte; PixelLUTPtr = ^PixelLUTType; var line: LineType; IntArray: IntArrayPtr; i, j, value, min, max, tmin, tmax: LongInt; ScaleFactor: extended; hloc, vloc, wwidth, wheight, IntValue, SaveBytesPerRow: integer; tPort: GrafPtr; PixelLUT: PixelLUTPtr; FixedScale: boolean; str1, str2, str3: str255; begin with info^ do begin if PixelsPerLine > MaxLine then exit(Import16BitImage); PixelLUT := PixelLUTPtr(NewPtr(SizeOf(PixelLUTType))); if PixelLUT = nil then begin PutMessage('Not enough memory to do 16 to 8-bit scaling.'); exit(Import16BitImage); end; if odd(PixelsPerLine) then begin SaveBytesPerRow := BytesPerRow; BytesPerRow := PixelsPerLine; {Needed to get PutLine to work.} end; IntArray := IntArrayPtr(PicBaseAddr); min := 999999; max := -999999; for i := 0 to ImageSize - 1 do begin if ImportSwapBytes then begin IntValue := IntArray^[i]; swap2bytes(IntValue); IntArray^[i] := IntValue; end; value := IntArray^[i]; if (ImportCustomDepth = SixteenBitsUnsigned) and (value < 0) then value := value + 65536; if value > max then max := value; if value < min then min := value; end; str1 := concat('min=', long2str(min), cr, 'max=', long2str(max)); str2 := ''; FixedScale := not ImportAutoScale; if FixedScale then begin tmin := round(ImportMin); tmax := round(ImportMax); if ((tmax - tmin) < 65536) and (tmin <= tmax) then begin min := tmin; max := tmax; str2 := concat(cr, 'fixed: ', long2str(min), '-', long2str(max)); end; end; ScaleFactor := 253.0 / (max - min); RealToString(ScaleFactor, 1, 4, str3); ShowMessage(concat(str1, str2, cr, 'scale factor= ', str3)); j := 0; for i := min to max do begin PixelLUT^[j] := round((i - min) * ScaleFactor + 1); j := j + 1; end; i := 0; for vloc := 0 to nlines - 1 do begin for hloc := 0 to PixelsPerLine - 1 do begin value := IntArray^[i]; if (ImportCustomDepth = SixteenBitsUnsigned) and (value < 0) then value := value + 65536; if FixedScale then begin if value < min then value := min; if value > max then value := max; end; line[hloc] := PixelLUT^[value - min]; i := i + 1; end; PutLine(0, vloc, PixelsPerLine, line); end; if ImportCalibrate then begin fit := StraightLine; nCoefficients := 2; coefficient[1] := max; coefficient[2] := (min - max) / 255; DensityCalibrated := true; ZeroClip := false; UpdateTitleBar; end else DensityCalibrated := false; FileDepth := ImportCustomDepth; if odd(PixelsPerLine) then BytesPerRow := SaveBytesPerRow; DisposPtr(ptr(PixelLUT)); SetHandleSize(PicBaseHandle, PixMapSize); end; {with} end; procedure ReadStackSlices (f, nExtraImages: integer; var table: TiffIFDTable); var i, err, SaveCS: integer; h: handle; DataSize: LongInt; begin ShowMessage(CmdPeriodToStop); 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; LoopTime := TempStackInfo.LoopTime; SaveCS := CurrentSlice; 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; err := SetFPos(f, fsFromStart, table[i - 1].offset); err := fsread(f, DataSize, h^); if odd(PixelsPerLine) then UnpackLines; if PictureType = InvertedTIFF then InvertPic; UpdatePicWindow; if CommandPeriod then begin beep; nSlices := i; wait(60); leave; end; end; {for} if (MaxBlock < MinFree) and (nSlices > 1) then begin repeat DisposHandle(PicBaseH[nSlices]); nSlices := nSlices - 1; until (MaxBlock > MinFree) or (nSlices = 1); PutMessage(concat('Not enough memory to open all ', long2str(nExtraImages + 1), ' slices in the stack.')); end; CurrentSlice := SaveCS; if CurrentSlice > nSlices then CurrentSlice := 1; SelectSlice(CurrentSlice); UpdateTitleBar; UpdateWindowsMenuItem(ImageSize * nSlices, title, PicNum); 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) 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; function OpenFile (fname: str255; vnum: integer): boolean; var ticks, ByteCount, i, DataSize, NextTiffIFD: LongInt; err: OSErr; f: integer; line, pixel: integer; r2, r3: rect; p: ptr; value: byte; iptr: ptr; SaveInfo: InfoPtr; is16bits: boolean; begin OpenFile := false; ShowWatch; err := fsopen(fname, vNum, f); SaveInfo := Info; iptr := NewPtr(SizeOf(PicInfo)); if iptr = nil then begin PutMemoryAlert; DisposPtr(iptr); err := fsclose(f); exit(OpenFile) end; Info := pointer(iptr); info^ := SaveInfo^; with Info^ do begin ColorMapOffset := 0; if not OpenHeader(f, fname, vnum, NextTiffIFD) then begin DisposPtr(iptr); err := fsclose(f); Info := SaveInfo; exit(OpenFile) end; is16bits := (WhatToOpen = OpenCustom) and (ImportCustomDepth <> EightBits); PicBaseAddr := GetImageMemory(SaveInfo, PicBaseHandle, is16bits); if PicBaseAddr = nil then begin err := fsclose(f); exit(OpenFile) end; MakeNewWindow(fname); err := SetFPos(f, fsFromStart, ImageDataOffset); if PictureType = FourBitTIFF then Read4BitTIFF(f) else begin DataSize := LongInt(nlines) * PixelsPerLine; if is16bits then DataSize := DataSize * 2; err := fsread(f, DataSize, PicBaseAddr); if IOCheck(err) <> NoErr then begin err := fsclose(f); exit(OpenFile) end; end; if is16bits then Import16BitImage; if odd(PixelsPerLine) and (PictureType <> FourBitTiff) then UnpackLines; if (PictureType = pdp11) or (PictureType = InvertedTIFF) or ((PictureType = Imported) and is16bits) or ((PictureType = Imported) and (WhatToImport = ImportMCID)) then InvertPic; if PictureType = FourBitTIFF then PictureType := imported; vref := vnum; if PixMapSize > UndoBufSize then PutWarning; revertable := FileDepth = EightBits; end; {with} if TempStackInfo.nSlices > 0 then OpenStack(f) else if NextTiffIFD > 0 then OpenExtraTiffImages(f, NextTiffIFD); err := fsclose(f); OpenFile := true; end; procedure InitPictBuffer (howBig: LongInt); begin repeat PictBuffer := NewPtr(howBig); if PictBuffer = nil then howBig := howBig div 2; until PictBuffer <> nil; DisposPtr(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 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 BitInfoCount := BitInfoCount + 1; for i := 0 to size do info^.cTable[i].rgb := ctTable[i].rgb; if size > 0 then with info^ do begin LutMode := ColorLut; SetupPseudocolor; end; end; end; procedure GetClutFromPict (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; SaveProcsPtr: QDProcsPtr; tPort: GrafPtr; err: osErr; begin with info^ do begin GetPort(tPort); SetPort(wptr); SaveProcsPtr := pointer(wptr^.grafProcs); SetStdCProcs(tempProcs); tempProcs.bitsProc := @BitInfo; tempProcs.getPicProc := @GetPICTData; BitInfoCount := 0; wptr^.grafProcs := @tempProcs; err := SetFPos(PictF, fsFromStart, 512 + SizeOf(Picture)); FillPictBuffer; if not PictReadErr then DrawPicture(thePict, thePict^^.picFrame); SetPort(tPort); wptr^.grafProcs := pointer(SaveProcsPtr); end; LoadLUT(info^.cTable); end; function OpenPict;{(fname:str255; vnum:integer; Reverting:boolean):boolean} var err: OSErr; i: integer; value: byte; iptr: ptr; PictSize, HowBig, NextTiffIFD: LongInt; thePict: PicHandle; tPort: GrafPtr; tempProcs: CQDProcs; SaveProcsPtr: QDProcsPtr; SaveInfo: InfoPtr; procedure Abort; begin if not reverting then begin DisposPtr(pointer(Info)); Info := SaveInfo; LoadLUT(info^.cTable); end; if thePict <> nil then DisposHandle(handle(thePict)); if PictF <> 0 then err := fsclose(PictF); exit(OpenPict); end; begin PictF := 0; thePict := nil; OpenPict := false; PictReadErr := false; ShowWatch; SaveInfo := Info; err := fsopen(fname, vNum, PictF); if IOCheck(err) <> 0 then Abort; if not Reverting then begin iptr := NewPtr(SizeOf(PicInfo)); if iptr = nil then begin PutMemoryAlert; DisposPtr(iptr); err := fsclose(PictF); exit(OpenPict) end; Info := pointer(iptr); info^ := SaveInfo^; end; with Info^ do begin err := GetEof(PictF, PictSize); if IOCheck(err) <> 0 then Abort; PictSize := PictSize - 512; if PictSize <= 0 then Abort; WhatToOpen := OpenPICT2; if not OpenHeader(PictF, fname, vnum, NextTiffIFD) then Abort; thePict := PicHandle(NewHandle(SizeOf(Picture))); if thePict = nil then Abort; err := SetFPos(PictF, fsFromStart, 512); if IOCheck(err) <> 0 then Abort; howBig := SizeOf(Picture); err := FSRead(PictF, howBig, Pointer(thePict^)); if IOCheck(err) <> 0 then Abort; with thePict^^.PicFrame do begin nlines := bottom - top; PixelsPerLine := right - left; end; if not Reverting then begin PicBaseAddr := GetImageMemory(SaveInfo, PicBaseHandle, false); if PicBaseAddr = nil then begin DisposHandle(handle(thePict)); err := fsclose(PictF); exit(OpenPict) end; MakeNewWindow(fname); end; if (PixMapSize > UndoBufSize) and (not Reverting) then begin PutWarning; ShowWatch; 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 IOCheck(err) <> NoErr then begin DisposHandle(handle(thePict)); err := fsclose(PictF); exit(OpenPict) end; fitsInPictBuffer := true; end else fitsInPictBuffer := false; if ((LutMode = ColorLut) or (LutMode = CustomGrayscale)) and (not UseExistingLUT) then GetClutFromPict(thePict); if isGrayScaleLUT then ResetGrayMap; GetPort(tPort); SetPort(GrafPtr(osPort)); pmForeColor(BlackIndex); pmBackColor(WhiteIndex); RGBForeColor(BlackRGB); RGBBackColor(WhiteRGB); EraseRect(PicRect); SaveProcsPtr := pointer(osPort^.grafProcs); SetStdCProcs(tempProcs); tempProcs.getPicProc := @GetPICTData; osPort^.grafProcs := @TempProcs; err := SetFPos(PictF, fsFromStart, 512 + SizeOf(Picture)); FillPictBuffer; if not PictReadErr then DrawPicture(thePict, PicRect); osPort^.grafProcs := pointer(SaveProcsPtr); DisposHandle(handle(thePict)); DisposPtr(PictBuffer); pmForeColor(ForegroundIndex); pmBackColor(BackgroundIndex); SetPort(tPort); 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(wptr); SaveProcsPtr := pointer(wptr^.grafProcs); SetStdCProcs(tempProcs); tempProcs.bitsProc := @BitInfo; BitInfoCount := 0; wptr^.grafProcs := @tempProcs; DrawPicture(thePict, thePict^^.picFrame); wptr^.grafProcs := pointer(SaveProcsPtr); end; LoadLUT(info^.cTable); end; function OpenPICS (name: str255; fRefNum: integer): boolean; var RefNum, picID, hOffset, vOffset: integer; err: OSErr; PicH: PicHandle; h: handle; MemError, Aborted: boolean; FrameRect: rect; procedure Abort; begin CloseResFile(RefNum); exit(OpenPICS); end; begin OpenPics := false; if MaxBlock < MinFree then begin PutMessage('Insufficient memory to open PICS file.'); exit(OpenPICS); end; err := SetVol(nil, fRefNum); RefNum := OpenResFile(name); if RefNum = -1 then begin PutMessage('Unable to open PICS file.'); exit(OpenPICS); end; PicH := GetPicture(128); if PicH = nil then Abort; 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 Abort; with info^ do begin revertable := false; StackInfo := StackInfoPtr(NewPtr(SizeOf(StackInfoRec))); if StackInfo = nil then Abort; with StackInfo^ do begin SliceSpacing := 0.0; LoopTime := 0.0; nSlices := 1; CurrentSlice := 1; PicBaseH[1] := PicBaseHandle; end; end; if not UseExistingLUT then GetCLUT(picH); with info^, Info^.StackInfo^ do begin SetPort(GrafPtr(osPort)); DrawPicture(picH, PicRect); DisposHandle(handle(picH)); UpdatePicWindow; picID := 129; MemError := false; repeat PicH := GetPicture(picID); if (PicH = nil) or (ResError <> NoErr) then Leave; h := NewHandle(PixMapSize); if (h = nil) or (MaxBlock < MinFree) then begin if h <> nil then DisposHandle(h); if PicH <> nil then DisposHandle(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; if not EqualRect(FrameRect, PicRect) then BlockMove(PicBaseH[CurrentSlice - 1]^, PicBaseH[CurrentSlice]^, PixMapSize); DrawPicture(picH, FrameRect); DisposHandle(handle(picH)); UpdatePicWindow; UpdateTitleBar; Aborted := CommandPeriod; if Aborted then begin beep; wait(60); Leave; end; picID := picID + 1; until h = nil; CloseResFile(RefNum); if MemError then PutMessage('Not enough memory to open all images in PICS file.'); CurrentSlice := 1; SelectSlice(CurrentSlice); PictureType := PicsFile; Revertable := false; UpdateTitleBar; UpdateWindowsMenuItem(ImageSize * nSlices, title, PicNum); if not MemError and not Aborted then OpenPICS := true; end; {with} end; procedure OpenAll (reply: SFReply); {Opens all appropriate files in a folder. Original version contributed by Ira Rampil.} var OpenedOK: boolean; RefNum, index: integer; name: Str255; ftype: OSType; err: OSErr; PB: HParamBlockRec; begin RefNum := reply.vRefNum; index := 0; while true do begin index := index + 1; with PB do begin ioCompletion := nil; ioNamePtr := @name; ioVRefNum := RefNum; ioVersNum := 0; ioFDirIndex := index; err := PBGetFInfo(@PB, false); 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); end; {while} end; procedure UpdateFileIcons (reply: SFReply); {Changes the creator of all files in the current folder from 'IMAG'(files created by V1.40 and earlier) to 'Imag'.} var OpenedOK: boolean; RefNum, index: integer; name: Str255; ftype, fcreator: OSType; err: OSErr; PB: HParamBlockRec; TheInfo: FInfo; count: integer; begin RefNum := reply.vRefNum; index := 0; count := 0; ShowWatch; while true do begin index := index + 1; with PB do begin ioCompletion := nil; ioNamePtr := @name; ioVRefNum := RefNum; ioVersNum := 0; ioFDirIndex := index; err := PBGetFInfo(@PB, false); if err = fnfErr then leave; ftype := ioFlFndrInfo.fdType; fcreator := ioFlFndrInfo.fdCreator; end; if (fCreator = 'IMAG') and ((ftype = 'IPIC') or (ftype = 'PICT') or (ftype = 'TIFF') or (ftype = 'ICOL')) then begin err := GetFInfo(name, RefNum, TheInfo); if err <> NoErr then leave; TheInfo.fdCreator := 'Imag'; err := SetFInfo(name, RefNum, TheInfo); if err <> NoErr then leave; err := FlushVol(nil, RefNum); count := count + 1; end; end; {while} if count = 0 then PutMessage('None of the files in the current folder use the old icons.') else PutMessage(concat('The creator type of ', long2str(count), ' files in the current folder was changed from ''IMAG'' to ''Imag''.')); end; function OpenDialogHook (item: integer; theDialog: DialogPtr): integer; const OpenAllID = 11; KeepLutID = 12; UpdateIconsID = 13; var i: integer; begin if (item = -1) and UseExistingLUT then SetDialogItem(theDialog, KeepLutID, 1); if item = OpenAllID then begin OpenAllFiles := not OpenAllFiles; SetDialogItem(theDialog, OpenAllID, ord(OpenAllFiles)); end; if item = KeepLutID then begin UseExistingLUT := not UseExistingLUT; SetDialogItem(theDialog, KeepLutID, ord(UseExistingLut)); end; if item = UpdateIconsID then begin UpdateIcons := not UpdateIcons; SetDialogItem(theDialog, UpdateIconsID, ord(UpdateIcons)); end; OpenDialogHook := item; end; function DoOpen (FileName: str255; RefNum: integer): boolean; const MyDialogID = 70; var where: Point; reply: SFReply; b: boolean; sfPtr: ^SFTypeList; TypeList: array[0..8] of OSType; FileType: OSType; OKToContinue: boolean; FinderInfo: FInfo; err: OSErr; begin KillOperation; DisableDensitySlice; OpenAllFiles := false; UseExistingLUT := false; UpdateIcons := 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} sfPtr := @TypeList; SFPGetFile(Where, '', nil, 10, sfPtr^, @OpenDialogHook, 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 UpdateIcons then begin UpdateFileIcons(reply); exit(DoOpen); end; if reply.good and OpenAllFiles then begin OpenAll(reply); 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) else if FileType = 'PICS' then b := OpenPICS(FileName, RefNum) else if FileType = 'Iout' then OpenOutline(FileName, RefNum) else begin WhatToOpen := OpenUnknown; b := OpenFile(FileName, RefNum) end; info^.ScaleToFitWindow := false; end; end; procedure ImportAllFiles (reply: SFReply); var OpenedOK: boolean; RefNum, index: integer; name: Str255; ftype: OSType; err: OSErr; PB: HParamBlockRec; begin RefNum := reply.vRefNum; index := 0; while true do begin index := index + 1; with PB do begin ioCompletion := nil; ioNamePtr := @name; ioVRefNum := RefNum; ioVersNum := 0; ioFDirIndex := index; err := PBGetFInfo(@PB, false); if err = fnfErr then exit(ImportAllFiles); ftype := ioFlFndrInfo.fdType; end; if not OpenFile(name, RefNum) then exit(ImportAllFiles); if CommandPeriod then begin beep; exit(ImportAllFiles); end; end; {while} end; procedure EditImportParameters; const WidthID = 2; HeightID = 3; OffsetID = 4; FixedID = 8; MinID = 11; MaxID = 12; var mylog: DialogPtr; item, fwidth: integer; begin mylog := GetNewDialog(110, nil, pointer(-1)); SetDNum(MyLog, WidthID, ImportCustomWidth); SelIText(MyLog, WidthID, 0, 32767); SetDNum(MyLog, HeightID, ImportCustomHeight); SetDNum(MyLog, OffsetID, ImportCustomOffset); SetDialogItem(MyLog, FixedID, ord(not ImportAutoScale)); if WhatToImport = ImportText then fwidth := 2 else fwidth := 0; SetDReal(MyLog, MinID, ImportMin, fwidth); SetDReal(MyLog, MaxID, ImportMax, fwidth); OutlineButton(MyLog, ok, 16); repeat ModalDialog(nil, item); if item = WidthID then begin ImportCustomWidth := GetDNum(MyLog, WidthID); if (ImportCustomWidth < 0) or (ImportCustomWidth > MaxPicSize) then begin ImportCustomWidth := 512; SetDNum(MyLog, WidthID, ImportCustomWidth); end; end; if item = HeightID then begin ImportCustomHeight := GetDNum(MyLog, HeightID); if ImportCustomHeight < 0 then begin ImportCustomHeight := 512; SetDNum(MyLog, HeightID, ImportCustomHeight); end; end; if item = OffsetID then begin ImportCustomOffset := GetDNum(MyLog, OffsetID); if ImportCustomOffset < 0 then begin ImportCustomOffset := 0; SetDNum(MyLog, OffsetID, ImportCustomOffset); end; end; if item = FixedID then begin ImportAutoScale := not ImportAutoScale; SetDialogItem(mylog, FixedID, ord(not ImportAutoScale)); end; if item = MinID then begin ImportMin := GetDReal(MyLog, MinID); ImportAutoScale := false; SetDialogItem(MyLog, FixedID, 1); end; if item = MaxID then begin ImportMax := GetDReal(MyLog, MaxID); ImportAutoScale := false; SetDialogItem(MyLog, FixedID, 1); end; until item = ok; DisposDialog(mylog); end; function ImportDialogHook (item: integer; myLog: DialogPtr): integer; const TiffID = 11; McidID = 12; TextID = 13; LutID = 14; CustomID = 15; WidthAndHeightID = 16; OffsetID = 17; EightBitsID = 18; SixteenBitsUnsignedID = 19; SixteenBitsSignedID = 20; SwapBytesID = 21; ImportAllID = 22; EditID = 23; CalibrateID = 24; var i: integer; procedure SetRadioButtons1; var i: integer; begin SetDialogItem(mylog, TiffID, 0); SetDialogItem(mylog, McidID, 0); SetDialogItem(mylog, LutID, 0); SetDialogItem(mylog, TextID, 0); SetDialogItem(mylog, CustomID, 0); case WhatToImport of ImportTiff: SetDialogItem(mylog, TiffID, 1); ImportMcid: SetDialogItem(mylog, McidID, 1); ImportLUT: SetDialogItem(mylog, LutID, 1); ImportText: SetDialogItem(mylog, TextID, 1); ImportCustom: SetDialogItem(mylog, CustomID, 1); end; end; procedure SetRadioButtons2; var i: integer; begin SetDialogItem(mylog, EightBitsID, 0); SetDialogItem(mylog, SixteenBitsUnsignedID, 0); SetDialogItem(mylog, SixteenBitsSignedID, 0); case ImportCustomDepth of EightBits: SetDialogItem(mylog, EightBitsID, 1); SixteenBitsUnsigned: SetDialogItem(mylog, SixteenBitsUnsignedID, 1); SixteenBitsSigned: SetDialogItem(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; SetDialogItem(mylog, SwapBytesID, ord(ImportSwapBytes)); SetDialogItem(mylog, ImportAllID, ord(ImportAll)); SetDialogItem(mylog, CalibrateID, ord(ImportCalibrate)); end; if (item >= TiffID) and (item <= CustomID) then begin case item of TiffID: WhatToImport := ImportTiff; McidID: WhatToImport := ImportMCID; LutID: WhatToImport := ImportLUT; TextID: WhatToImport := ImportText; CustomID: WhatToImport := ImportCustom; end; SetRadioButtons1; end; if item = EditID then begin EditImportParameters; WhatToImport := ImportCustom; SetRadioButtons1; ShowParameters; 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; SetDialogItem(mylog, SwapBytesID, ord(ImportSwapBytes)); WhatToImport := ImportCustom; SetRadioButtons1; end; if item = ImportAllID then begin ImportAll := not ImportAll; SetDialogItem(mylog, ImportAllID, ord(ImportAll)); end; if item = CalibrateID then begin ImportCalibrate := not ImportCalibrate; SetDialogItem(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: boolean; begin ImportFile := true; DisableDensitySlice; if not macro then ImportAll := false; if FileName = '' then begin where.v := 50; where.h := 50; SFPGetFile(Where, '', nil, -1, typeList, @ImportDialogHook, 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; case WhatToImport of ImportTiff: WhatToOpen := OpenTiff; ImportMCID: WhatToOpen := OpenImported; ImportCustom: begin if (ImportCustomDepth <> EightBits) and (ImportCustomWidth > MaxLine) then begin PutMessage(concat('Maximum width of imported 16-bit images is ', long2str(MaxLine), '.')); exit(ImportFile); end; WhatToOpen := OpenCustom; end; ImportLUT: begin DoImportLut(FileName, RefNum); exit(ImportFile); end; ImportText: begin ImportFile := ImportTextFile(FileName, RefNum); exit(ImportFile); end; end; if ImportAll then ImportAllFiles(reply) else b := OpenFile(FileName, RefNum); end; procedure RevertToSaved; var fname: str255; err, f: integer; ok: boolean; 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); err := fsread(f, ImageSize, PicBaseAddr); with info^ do if (PictureType = PDP11) or (PictureType = InvertedTIFF) or (PictureType = imported) then InvertPic; if odd(PixelsPerLine) then UnpackLines; UpdatePicWindow; end; err := fsclose(f); RoiShowing := false; end; OpPending := false; Changes := false; end; {with} end; procedure FindWhatToPrint; var kind: integer; WhichWindow: WindowPtr; begin WhatToPrint := NothingToPrint; WhichWindow := FrontWindow; kind := WindowPeek(WhichWindow)^.WindowKind; if (kind = PicKind) and info^.RoiShowing and measuring then kind := ValuesKind; case kind of PicKind: if info^.RoiShowing then WhatToPrint := PrintSelection else WhatToPRint := PrintImage; HistoKind: WhatToPrint := PrintHistogram; ProfilePlotKind, CalibrationPlotKind: WhatToPrint := PrintPlot; ValuesKind, ResultsKind: if mCount > 0 then WhatToPrint := PrintMeasurements; otherwise ; end; if (WhatToPrint = NothingToPRint) and (info <> NoInfo) then WhatToPrint := PrintImage; end; procedure UpdateFileMenu; var ShowItems, isSelection: boolean; i: integer; str, str2: str255; fwptr: WindowPtr; kind: integer; begin ShowItems := Info <> NoInfo; fwptr := FrontWindow; kind := WindowPeek(fwptr)^.WindowKind; with info^ do isSelection := RoiShowing and (RoiType = RectRoi); if OptionKeyWasDown then begin SetItem(FileMenuH, CloseItem, 'Close All╔'); SetItem(FileMenuH, SaveItem, 'Save All'); SetMenuItem(FileMenuH, CloseItem, ShowItems); end else begin SetItem(FileMenuH, CloseItem, 'Close╔'); with info^ do if isSelection and (PictureType <> TiffFile) and (PictureType <> PictFile) and (kind = PicKind) then SetItem(FileMenuH, SaveItem, 'Save Selection') else SetItem(FileMenuH, SaveItem, 'Save'); SetMenuItem(FileMenuH, CloseItem, ShowItems or (kind = ProfilePlotKind) or (kind = CalibrationPlotKind) or (kind = HistoKind)); end; case kind 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 (SaveAsWhat <> AsPalette) and (fwptr <> ResultsWindow) then SetItem(FileMenuH, SaveAsItem, 'Save Selection As╔') else SetItem(FileMenuH, SaveAsItem, 'Save As╔'); if isSelection and (ExportAsWhat <= AsText) then SetItem(FileMenuH, ExportItem, 'Export Selection As╔') else SetItem(FileMenuH, ExportItem, 'Export╔'); for i := SaveItem to SaveAsItem do SetMenuItem(FileMenuH, i, ShowItems); SetMenuItem(FileMenuH, ExportItem, ShowItems); if isSelection then str := 'Duplicate Selection' else str := 'Duplicate'; SetItem(FileMenuH, DuplicateItem, str); for i := DuplicateItem to GetInfoItem do SetMenuItem(FileMenuH, i, ShowItems); SetMenuItem(FileMenuH, RevertItem, info^.Revertable); FindWhatToPrint; case WhatToPrint of NothingToPrint: str := ''; PrintImage: str := 'Image'; PrintSelection: str := 'Selection'; PrintPlot: str := 'Plot'; PrintHistogram: str := 'Histogram'; PrintMeasurements: str := 'Measurements'; end; SetItem(FileMenuH, PrintItem, concat('Print ', str, '╔')); SetMenuItem(FileMenuH, PrintItem, WhatToPrint <> NothingToPrint); 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; procedure SaveScreen; var err, RefNum: integer; TheInfo: FInfo; name: str255; ok, NewFile: boolean; SaveInfo: InfoPtr; SaveNoInfoRec: PicInfo; ShutterSound: handle; begin name := 'Screen'; err := GetVol(nil, RefNum); err := GetFInfo(name, RefNum, TheInfo); case err of NoErr: begin if TheInfo.fdType <> 'PICT' then begin TypeMismatch(name); exit(SaveScreen) end; NewFile := false; end; FNFerr: begin err := create(name, RefNum, 'Imag', 'PICT'); if IOCheck(err) <> 0 then exit(SaveScreen); NewFile := true; end; otherwise if IOCheck(err) <> 0 then exit(SaveScreen) end; ShutterSound := GetResource('snd ', 100); if ShutterSound <> nil then begin err := SndPlay(nil, ShutterSound, false); ReleaseResource(ShutterSound); end; SaveInfo := info; SaveNoInfoRec := NoInfoRec; with NoInfo^ do begin PixelsPerLine := ScreenWidth; nLines := ScreenHeight; osPort := cScreenPort; SetRect(PicRect, 0, 0, ScreenWidth, ScreenHeight); LutMode := info^.LutMode; cTable := info^.cTable; end; info := NoInfo; ok := SavePICTFile(name, RefNum, false, NewFile); NoInfoRec := SaveNoInfoRec; info := SaveInfo; if ok then PutMessage('The screen has been dumped to a PICT file named ╥Screen╙ in the same folder as Image.'); 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} SetDialogItem(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); SelIText(theDialog, EditTextID, 0, 32767); end; for i := RawID to xyCoordinatesID do SetDialogItem(theDialog, i, 0); SetDialogItem(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 with info^ do begin if (name = '') or (RefNum = 0) then begin where.v := 50; where.h := 50; if name = '' then name := SuggestedExportName; SFPPutFile(Where, 'Save as?', name, @ExportHook, reply, CustomDialogID, nil); if not reply.good then begin macro := false; exit(Export); end; with reply do begin name := fname; RefNum := vRefNum; DefaultRefNum := RefNum; end; 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 PutMessage('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. 
