unit ImgMarkup; { [ImgMarkup] [1.2] Delphi 2005 December 2005 LICENSE The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at "http://www.mozilla.org/MPL/" Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for the specific language governing rights and limitations under the License. The Original Code is "[ImgMarkup.pas]". Portions of this code are adapted from the graphics32 Image View Layers Example: see below for the licence block which refers to those portions of code. The Initial Developer of the Original Code is Martin Holmes (Victoria, BC, Canada, "http://www.mholmes.com/"). Copyright (C) 2005 Martin Holmes and the University of Victoria Computing and Media Centre. The code was co-developed for university and personal projects, and rights are shared by Martin Holmes and the University of Victoria. All Rights Reserved. } {MDH_Comments: This form is designed to be a multi-purpose tool for annotating images, to be used initially for the creation of XML files annotating images for academic projects, and later to become a component in other software (possibly Hot Potatoes) for the creation of interactive exercises which involve answering questions by clicking on specific parts of an image. Some of this code is modelled on, or adapted from, the graphics32 Image View Layers Example, by Alex Denisov and Andre Beckedorf. I have included the original MPL licence for that code below. } (* ***** BEGIN LICENSE BLOCK ***** * Version: MPL 1.1 * * The contents of this file are subject to the Mozilla Public License Version * 1.1 (the "License"); you may not use this file except in compliance with * the License. You may obtain a copy of the License at * http://www.mozilla.org/MPL/ * * Software distributed under the License is distributed on an "AS IS" basis, * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License * for the specific language governing rights and limitations under the * License. * * The Original Code is Image View Layers Example * * The Initial Developer of the Original Code is * Alex A. Denisov * * Portions created by the Initial Developer are Copyright (C) 2000-2005 * the Initial Developer. All Rights Reserved. * * Contributor(s): * Andre Beckedorf * * ***** END LICENSE BLOCK ***** *) interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Menus, ExtCtrls, JPeg, ExtDlgs, StdCtrls, GR32, GR32_Image, GR32_Layers, GR32_RangeBars, GR32_Filters, GR32_Transforms, GR32_Resamplers, TntForms, TntExtCtrls, TntStdCtrls, TntMenus, ToolWin, ComCtrls, TntComCtrls, ImgList, ActnList, TntActnList, AppEvnts, Buttons, TntButtons, TntDialogs, TntExtDlgs, XDOM_3_1, GraphicEx, XMLGlobals, XMLRoutines, FileFunctions, FormState, FileCtrl, RecentFiles, Browsers, XMLUtilities, SplashAbout, jclUnicode, JvExStdCtrls, JvCombobox, JvColorCombo, mdhGraphics, StdActns, global_resources, JvListComb, ShellAPI, XMLRulesUtils, FileOverwriteConfirm, TntClasses, TntSysUtils, Clipbrd, AnnotationCategories, icons, mdhLibxml2, IMTDocGlobals; //TODO: Check whether this class and the associated functions: //GetImgViewHScrollPos and GetImgViewVScrollPos are needed //MDH: Cracker class to get at protected scrollbar positions (not used yet). {type TImgViewAccess = class(TCustomImgView32); } //MDH: Special subclass of TPositionedLayer that includes a data structure for //the XML and a couple of I/O functions. type TPositionedLayerWithXML = class(TPositionedLayer) private fAnnTitle: WideString; fAnnText: WideString; fAreaShape: integer; fDrawShape: Boolean; fColor: TColor; function GetCenterPoint: TPoint; public constructor Create(ALayerCollection: TLayerCollection); override; function ReportRectTag(id: WideString; IncludeNS: Boolean): WideString;//Reports the area as an SVG tag function ReportDivTag(LinkedID, TypeString: WideString): WideString; published property AnnTitle: WideString read fAnnTitle write fAnnTitle; property AnnText: WideString read fAnnText write fAnnText; property AreaShape: integer read fAreaShape write fAreaShape default 0; property DrawShape: Boolean read fDrawShape write fDrawShape; property CenterPoint: TPoint read GetCenterPoint; property Color: TColor read fColor write fColor; end; type TRectDomNodeFilter = class(TDomNodeFilter) FNodeType: TDOMWhatToShow; FReject: Boolean; public constructor Create(nodeType: TDomWhatToShow; reject: Boolean=false); function AcceptNode(const node: TdomNode): TdomFilterResult; override; end; TTagDomNodeFilter = class(TDomNodeFilter) FNodeType: TDOMWhatToShow; FReject: Boolean; FTagName: WideString; public constructor Create(nodeType: TDomWhatToShow; TagName: WideString; reject: Boolean=false); function AcceptNode(const node: TdomNode): TdomFilterResult; override; end; //This filter is used to constrain the content of annotation divs to the DTD. //It relies on a hard-coded list of acceptable children of "div". //A true validation system would be preferable, but very complicated to //implement. TAnnotationContentFilter = class(TDomNodeFilter) FNodeType: TDOMWhatToShow; FReject: Boolean; public constructor Create(nodeType: TDomWhatToShow; reject: Boolean=false); function AcceptNode(const node: TdomNode): TdomFilterResult; override; end; TTagAndAttributeDomNodeFilter = class(TDomNodeFilter) FNodeType: TDOMWhatToShow; FTagName: WideString; FAttributeName: WideString; FAttributeValue: WideString; FReject: Boolean; public constructor Create(nodeType: TDomWhatToShow; TagName, AttributeName, AttributeValue: WideString; Reject: Boolean=false); function AcceptNode(const node: TdomNode): TdomFilterResult; override; end; //MDH: This class is used for reading and writing data to disk, //using XDOM functionality type TImgDom = class private fXMLFilePath: WideString; fImagePath: WideString; fID: WideString; fLinkedImgView: TImgView32; fImgView32: TImgView32; fImageTitle: WideString; fImageDesc: WideString; fTeiHeader: WideString; fWrapperNodeFilter: TTagAndAttributeDomNodeFilter; fSVGNodeFilter: TTagDomNodeFilter; fRectNodeFilter: TTagDomNodeFilter; fLayerNodeFilter: TTagAndAttributeDomNodeFilter; fAnnotationContentFilter: TAnnotationContentFilter; fCurrDocTeiHeaderNode: TDomNode; fCurrDocWrapperNode: TDomNode; const teiHeaderOpen: WideString = '' + #13#10 + '' + #13#10 + '' + #13#10 + ''; teiHeaderClose: WideString = '' + #13#10 + '' + #13#10 + '

' + #13#10 + '

' + #13#10 + '' + #13#10 + ''; WrapperTypeString: WideString = 'imtAnnotatedImage'; LayerTypeString: WideString = 'imtAnnotationLayer'; function CreateWrapper: WideString; function FindWrapperNode: TDomNode; public DomImpl: TDomImplementation; XmlToDomParser: TXmlToDomParser; DomToXmlParser: TDomToXmlParser; CurrXMLDoc: TDomDocument; XMLDocNS: TDomDocumentNS; XMLDoc: TDomDocument; constructor Create(LinkedIV: TImgView32); destructor Destroy; override; procedure ClearAll; function SaveToPersistentXMLFile: Boolean; function SaveToXMLFile: Boolean; function LoadPersistentXMLDocument(FilePath: WideString): Boolean; //The following function is superceded by the one above; it will be removed at some point. function LoadXMLDocument(FilePath: WideString): Boolean; procedure CreateTeiHeader; published property LinkedImgView: TImgView32 read fImgView32 write fImgView32; property XMLFilePath: WideString read fXMLFilePath write fXMLFilePath; property ImagePath: WideString read fImagePath write fImagePath; property ID: WideString read fID write fID; property ImageTitle: WideString read fImageTitle write fImageTitle; property ImageDesc: WideString read fImageDesc write fImageDesc; property teiHeader: WideString read fTeiHeader write fTeiHeader; end; type TufrmImgMarkup = class(TTntForm) umnuMain: TTntMainMenu; umnFileNew: TTntMenuItem; umnFile: TTntMenuItem; umnOpen: TTntMenuItem; N6: TTntMenuItem; utbrMain: TTntToolBar; uspHorizontal: TTntSplitter; upnBottom: TTntPanel; cmbScale: TComboBox; ustScale: TTntStaticText; usbMain: TTntStatusBar; ualMain: TTntActionList; utbSep1: TTntToolButton; umnAreas: TTntMenuItem; umnNewArea: TTntMenuItem; umniDeleteArea: TTntMenuItem; utbNewArea: TTntToolButton; utbDeleteArea: TTntToolButton; aeMain: TApplicationEvents; aDeleteArea: TTntAction; aNewArea: TTntAction; udlgLoadImage: TTntOpenPictureDialog; udlgSaveFile: TTntSaveDialog; aSaveAs: TTntAction; aSave: TTntAction; aOpen: TTntAction; aNew: TTntAction; umnImportImage: TTntMenuItem; umnSave: TTntMenuItem; umnSaveAs: TTntMenuItem; udlgOpenFile: TTntOpenDialog; aImportImage: TTntAction; utbNew: TTntToolButton; utbOpen: TTntToolButton; utbSave: TTntToolButton; utbSaveAs: TTntToolButton; utbImportImage: TTntToolButton; utbSep3: TTntToolButton; utbSep2: TTntToolButton; upnImageInfo: TTntPanel; ustImageTitle: TTntStaticText; ueImageTitle: TTntEdit; ustImageDesc: TTntStaticText; umImageDesc: TTntMemo; uspBottomPanel: TTntSplitter; upnAnnotationData: TTntPanel; umsgSaveFileOrNot: TTntLabel; umsgUnableToLoadImage: TTntLabel; umsgReplaceImage: TTntLabel; umsgUnableToFindImage: TTntLabel; ustTitle: TTntStaticText; ueAnnTitle: TTntEdit; ustAnnotation: TTntStaticText; umAnnText: TTntMemo; ImgView: TImgView32; utbTeiHeader: TTntToolButton; dlgSpiralColor: TColorDialog; aTeiHeader: TTntAction; N1: TTntMenuItem; umnRecentFiles: TTntMenuItem; umsgConfirmDeleteLayer: TTntLabel; utbSep4: TTntToolButton; utbShowAreaList: TTntToolButton; aShowAreaList: TTntAction; aTranslate: TTntAction; umnHelp: TTntMenuItem; umnTutorial: TTntMenuItem; umsgNotWellFormed: TTntLabel; umsgXMLFileNotWellFormed: TTntLabel; umnAbout: TTntMenuItem; aAbout: TTntAction; N2: TTntMenuItem; umnShowAreaList: TTntMenuItem; jvcolcmbAnnColor: TJvColorComboBox; umnChangeAreaColor: TTntMenuItem; aChangeAreaColor: TTntAction; imgSplash: TImage; utbSep5: TTntToolButton; utbEditUndo: TTntToolButton; utbEditCut: TTntToolButton; utbEditCopy: TTntToolButton; utbEditPaste: TTntToolButton; utbEditDelete: TTntToolButton; utbEditSelectAll: TTntToolButton; umnEdit: TTntMenuItem; umnEditUndo: TTntMenuItem; N3: TTntMenuItem; umnEditCut: TTntMenuItem; umnEditCopy: TTntMenuItem; umnEditPaste: TTntMenuItem; umnEditDelete: TTntMenuItem; N4: TTntMenuItem; umnEditSelectAll: TTntMenuItem; utbSep6: TTntToolButton; utbPreferences: TTntToolButton; umnOptions: TTntMenuItem; umnPreferences: TTntMenuItem; aPreferences: TTntAction; utbTranslate: TTntToolButton; umnTranslate: TTntMenuItem; umsgUntitled: TTntLabel; jvicbShapes: TJvImageComboBox; aCreateWebView: TTntAction; umsgCannotSaveIllformedFile: TTntLabel; umsgShowInBrowser: TTntLabel; N5: TTntMenuItem; utbCreateWebView: TTntToolButton; utbSep7: TTntToolButton; umnTEI: TTntMenuItem; umnTeiHeader: TTntMenuItem; utbSep8: TTntToolButton; utbTutorial: TTntToolButton; utbWebViewPrefs: TTntToolButton; umnWebViewPrefs: TTntMenuItem; aWebViewPrefs: TTntAction; aTutorial: TTntAction; aSelectAll: TTntAction; aDelete: TTntAction; aPaste: TTntAction; aCopy: TTntAction; aCut: TTntAction; aUndo: TTntAction; umnCreateWebView: TTntMenuItem; aQuit: TTntAction; N7: TTntMenuItem; umnQuit: TTntMenuItem; procedure aQuitExecute(Sender: TObject); procedure upnImageInfoDblClick(Sender: TObject); procedure aWebViewPrefsExecute(Sender: TObject); procedure aTutorialExecute(Sender: TObject); procedure aSelectAllExecute(Sender: TObject); procedure aDeleteExecute(Sender: TObject); procedure aPasteExecute(Sender: TObject); procedure aCopyExecute(Sender: TObject); procedure aCutExecute(Sender: TObject); procedure aUndoExecute(Sender: TObject); procedure aCreateWebViewExecute(Sender: TObject); procedure TntFormMouseWheel(Sender: TObject; Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean); procedure jvicbShapesChange(Sender: TObject); procedure aPreferencesExecute(Sender: TObject); procedure jvcolcmbAnnColorChange(Sender: TObject); procedure aChangeAreaColorExecute(Sender: TObject); procedure aAboutExecute(Sender: TObject); procedure umnTestClick(Sender: TObject); procedure aTranslateExecute(Sender: TObject); procedure umAnnTextChange(Sender: TObject); procedure aShowAreaListExecute(Sender: TObject); procedure ImgViewMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer; Layer: TCustomLayer); procedure TntFormResize(Sender: TObject); procedure aTeiHeaderExecute(Sender: TObject); procedure TntFormClose(Sender: TObject; var Action: TCloseAction); procedure TntFormCloseQuery(Sender: TObject; var CanClose: Boolean); procedure aOpenExecute(Sender: TObject); procedure aImportImageExecute(Sender: TObject); procedure aNewExecute(Sender: TObject); procedure aSaveExecute(Sender: TObject); procedure aSaveAsExecute(Sender: TObject); procedure TntFormShow(Sender: TObject); procedure ueAnnTitleChange(Sender: TObject); procedure ImgViewKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState); procedure aeMainIdle(Sender: TObject; var Done: Boolean); procedure aDeleteAreaExecute(Sender: TObject); procedure aNewAreaExecute(Sender: TObject); procedure cbOptRedrawClick(Sender: TObject); procedure cmbScaleChange(Sender: TObject); procedure FormDestroy(Sender: TObject); procedure FormCreate(Sender: TObject); procedure MagnChange(Sender: TObject); procedure ImgViewMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer; Layer: TCustomLayer); procedure ImgViewPaintStage(Sender: TObject; Buffer: TBitmap32; StageNum: Cardinal); procedure mnFlattenClick(Sender: TObject); procedure ImgViewMouseWheelUp(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); procedure ImgViewMouseWheelDown(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); private FSelection: TPositionedLayerWithXML; fDocModified: Boolean; FFormStateSaver: TFormStateSaver; FRecentFiles: TRecentFiles; FAppClosing: Boolean; procedure SetDocModified(bVal: Boolean); procedure SetSelection(Value: TPositionedLayerWithXML); function CheckWellFormed: integer; //returns a dialog return value function MakeAnnTextWellFormed(InText: WideString): WideString; procedure WMEraseBkgnd(var Msg: TMessage); message WM_ERASEBKGND; procedure ShowLayerData(PLXML: TPositionedLayerWithXML); procedure StashLayerData(PLXML: TPositionedLayerWithXML); procedure StashImageData; procedure DisplayImageData; procedure ClearAnnotationData; procedure ClearAllData; procedure SetStatusText(const Value: WideString); function GetStatusText: WideString; function GetCaptionText: WideString; procedure SetCaptionText(const Value: WideString); procedure RefreshCaption; procedure RefreshStatus; function CheckSavedDocument(TheFileName: WideString): Boolean; procedure WMDROPFILES( var Message: TWMDROPFILES ); message WM_DROPFILES; protected RBLayer: TRubberbandLayer; procedure LayerMouseDown(Sender: TObject; Buttons: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure RBResizing(Sender: TObject; const OldLocation: TFloatRect; var NewLocation: TFloatRect; DragState: TDragState; Shift: TShiftState); procedure PaintSimpleDrawingHandler(Sender: TObject; Buffer: TBitmap32); public ImgDom: TImgDom; SplashAbout: TSplashAbout; function CreatePositionedLayer: TPositionedLayerWithXML; procedure OpenImage(const FileName: string); procedure OpenFile(TheFileName: WideString); function SaveFile: Boolean; function SaveFileAs: Boolean; function CheckSaved: Boolean; function SaveScaledImage(TargetWidth: integer; FilePath: WideString; var ScaleFactor: Double; var OutputDimensions: TPoint): Boolean; // function GetImgViewHScrollPos: integer; //not used or needed yet, but maybe later.. // function GetImgViewVScrollPos: integer; //not used or needed yet, but maybe later.. procedure OpenRecent(Sender: TObject; const FileName: WideString); property Selection: TPositionedLayerWithXML read FSelection write SetSelection; property DocModified: Boolean read fDocModified write SetDocModified default False; property StatusText: WideString read GetStatusText write SetStatusText; property CaptionText: WideString read GetCaptionText write SetCaptionText; end; var ufrmImgMarkup: TufrmImgMarkup; implementation {$R *.DFM} uses TeiHeader, LayerList, translate, Preferences, WebViewPrefs; const RESAMPLER: array [Boolean] of TBitmap32ResamplerClass = (TNearestResampler, TDraftResampler); teiDocType: WideString = ''; // SVGOpener: WideString = ''; // SVGCloser: WideString = ''; SVGOpener: WideString = ''; SVGCloser: WideString = ''; TEIOpener: WideString = ''; TEISchemaOpener: WideString =''; TEICloser: WideString = ''; { TForm1 } {procedure TufrmImgMarkup.CreateNewImage(AWidth, AHeight: Integer; FillColor: TColor32); begin with ImgView do begin Selection := nil; RBLayer := nil; Layers.Clear; Scale := 1; Bitmap.SetSize(AWidth, AHeight); Bitmap.Clear(FillColor); // pnlImage.Visible := not Bitmap.Empty; end; end;} function TufrmImgMarkup.CreatePositionedLayer: TPositionedLayerWithXML; var P: TPoint; ScaledSize: integer; begin // get coordinates of the center of viewport with ImgView.GetViewportRect do P := ImgView.ControlToBitmap(Point((Right + Left) div 2, (Top + Bottom) div 2)); Result := TPositionedLayerWithXML.Create(ImgView.Layers); ScaledSize := Round(32*(1/ImgView.Scale)); //MDH: Set Scaled before setting size so that size is relative to the current view scale. //This makes the most sense from a usability point of view. Result.Scaled := True; Result.Location := FloatRect(P.X - ScaledSize, P.Y - ScaledSize, P.X + ScaledSize, P.Y + ScaledSize); // Result.Scaled := True; Result.MouseEvents := True; Result.OnMouseDown := LayerMouseDown; end; procedure TufrmImgMarkup.FormCreate(Sender: TObject); begin FAppClosing := False; // by default, PST_CLEAR_BACKGND is executed at this stage, // which, in turn, calls ExecClearBackgnd method of ImgView. // Here I substitute PST_CLEAR_BACKGND with PST_CUSTOM, so force ImgView // to call the OnPaintStage event instead of performing default action. with ImgView.PaintStages[0]^ do begin if Stage = PST_CLEAR_BACKGND then Stage := PST_CUSTOM; end; ImgView.RepaintMode := rmOptimizer; ImgDom := TImgDom.Create(ImgView); DocModified := False; jvicbShapes.Anchors := [akTop, akRight]; jvicbShapes.ItemIndex := 0; DragAcceptFiles(Self.Handle, True); end; procedure TufrmImgMarkup.FormDestroy(Sender: TObject); begin Selection := nil; RBLayer := nil; FreeAndNil(ImgDom); end; procedure TufrmImgMarkup.LayerMouseDown(Sender: TObject; Buttons: TMouseButton; Shift: TShiftState; X, Y: Integer); begin if Sender <> nil then begin Selection := TPositionedLayerWithXML(Sender); ufrmAreaList.FindAndSelectItem(Selection); end; end; procedure TufrmImgMarkup.MagnChange(Sender: TObject); begin ImgView.Invalidate; end; procedure TufrmImgMarkup.OpenImage(const FileName: string); begin ImgDom.ClearAll; with ImgView do begin try Selection := nil; RBLayer := nil; Layers.Clear; Scale := 1; cmbScale.Text := '100%'; //TODO -oMartin: figure out why the screen cursor fails to change here! Screen.Cursor := crHourglass; Application.ProcessMessages; try try Bitmap.LoadFromFile(FileName); Application.ProcessMessages; except WideMessageDlg(umsgUnableToLoadImage.Caption, mtWarning, [mbOK], 0); Exit; end; finally Screen.Cursor := crDefault; end; ImgDom.ImagePath := FileName; ImgDom.ImageTitle := ExtractFileName(FileName); ImgDom.ImageDesc := IntToStr(Bitmap.Width) + ' x ' + IntToStr(Bitmap.Height); DisplayImageData; finally //Any other final processing should go here, to ensure that state is returned to normal. end; end; end; procedure TufrmImgMarkup.PaintSimpleDrawingHandler(Sender: TObject; Buffer: TBitmap32); var Cx, Cy: Single; W2, H2: Single; I: Integer; ShapeColor: TColor32; begin if Sender is TPositionedLayerWithXML then begin if TPositionedLayerWithXML(Sender).DrawShape then begin ShapeColor := Color32(TPositionedLayerWithXML(Sender).Color); case TPositionedLayerWithXML(Sender).AreaShape of asSpiral: begin with TPositionedLayerWithXML(Sender).GetAdjustedLocation do begin Buffer.Canvas.Lock; W2 := (Right - Left) / 2; H2 := (Bottom - Top) / 2; Cx := Left + W2; Cy := Top + H2; Buffer.PenColor := ShapeColor; Buffer.MoveToF(Cx,Cy); for I := 0 to 240 do begin //This draws the red spiral Buffer.LineToFS(Cx + W2 * I / 200 * Cos(I / 8), Cy + H2 * I / 200 * Sin(I / 8)); end; Buffer.Canvas.Unlock; end; end; asRectangle: begin with TPositionedLayerWithXML(Sender).GetAdjustedLocation do begin Buffer.Canvas.Lock; Buffer.FrameRectTS(round(Left+1), round(Top+1), round(Right-1), round(Bottom-1), ShapeColor); Buffer.Canvas.Unlock; end; end; asCross: begin with TPositionedLayerWithXML(Sender).GetAdjustedLocation do begin Buffer.Canvas.Lock; Buffer.LineAS(round(Left), round(Top), round(Right), round(Bottom), ShapeColor, True); Buffer.LineAS(round(Left), round(Bottom), round(Right), round(Top), ShapeColor, True); Buffer.Canvas.Unlock; end; end; asEllipse: begin with TPositionedLayerWithXML(Sender).GetAdjustedLocation do begin Buffer.Canvas.Lock; Buffer.Canvas.Brush.Style := bsClear; Buffer.Canvas.Pen.Color := TPositionedLayerWithXML(Sender).Color; Buffer.Canvas.Ellipse(round(Left), round(Bottom), round(Right), round(Top)); Buffer.Canvas.Unlock; end; end; end; //end case end; //end if DrawShape end; //end if Sender is TPositionedLayerWithXML end; procedure TufrmImgMarkup.cmbScaleChange(Sender: TObject); var S: string; I: Integer; begin S := cmbScale.Text; S := StringReplace(S, '%', '', [rfReplaceAll]); S := StringReplace(S, ' ', '', [rfReplaceAll]); if S = '' then Exit; I := StrToIntDef(S, -1); if (I < 1) or (I > 2000) then I := Round(ImgView.Scale * 100) else ImgView.Scale := I / 100; cmbScale.Text := IntToStr(I) + '%'; cmbScale.SelStart := Length(cmbScale.Text) - 1; end; procedure TufrmImgMarkup.SetSelection(Value: TPositionedLayerWithXML); begin if Value <> FSelection then begin //MDH: stash the previous annotation data if FSelection <> nil then begin //Check that it's OK to stash it, and warn of XML errors. case CheckWellFormed of mrYes: StashLayerData(FSelection); mrCancel: begin //user presumably wants to stay with the current annotation and fix the //errors, so we need to reset the area window selection ufrmAreaList.FindAndSelectItem(FSelection); Exit; end; mrNo: StashLayerData(FSelection); end; end; if RBLayer <> nil then begin RBLayer.ChildLayer := nil; RBLayer.LayerOptions := LOB_NO_UPDATE; ImgView.Invalidate; end; FSelection := Value; if Value <> nil then begin ShowLayerData(FSelection); if RBLayer = nil then begin RBLayer := TRubberBandLayer.Create(ImgView.Layers); RBLayer.MinHeight := 1; RBLayer.MinWidth := 1; end else begin RBLayer.BringToFront; end; RBLayer.ChildLayer := Value; RBLayer.LayerOptions := LOB_VISIBLE or LOB_MOUSE_EVENTS or LOB_NO_UPDATE; RBLayer.OnResizing := RBResizing; ufrmAreaList.FindAndSelectItem(FSelection); end else begin ClearAnnotationData; if not FAppClosing then ufrmAreaList.uclbAreaList.ItemIndex := -1; end; end; end; procedure TufrmImgMarkup.WMEraseBkgnd(var Msg: TMessage); begin // disable form background cleaning Msg.Result := 1; end; procedure TufrmImgMarkup.ImgViewMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer; Layer: TCustomLayer); begin if Layer = nil then begin Selection := nil; ReleaseCapture; end; end; procedure TufrmImgMarkup.ImgViewPaintStage(Sender: TObject; Buffer: TBitmap32; StageNum: Cardinal); const //0..1 Colors: array [Boolean] of TColor32 = ($FFFFFFFF, $FFB0B0B0); var R: TRect; I, J: Integer; OddY: Integer; TilesHorz, TilesVert: Integer; TileX, TileY: Integer; TileHeight, TileWidth: Integer; begin TileHeight := 13; TileWidth := 13; TilesHorz := Buffer.Width div TileWidth; TilesVert := Buffer.Height div TileHeight; TileY := 0; for J := 0 to TilesVert do begin TileX := 0; OddY := J and $1; for I := 0 to TilesHorz do begin R.Left := TileX; R.Top := TileY; R.Right := TileX + TileWidth; R.Bottom := TileY + TileHeight; Buffer.FillRectS(R, Colors[I and $1 = OddY]); Inc(TileX, TileWidth); end; Inc(TileY, TileHeight); end; end; procedure TufrmImgMarkup.RBResizing(Sender: TObject; const OldLocation: TFloatRect; var NewLocation: TFloatRect; DragState: TDragState; Shift: TShiftState); var w, h, cx, cy: Single; nw, nh: Single; begin if DragState = dsMove then Exit; // we are interested only in scale operations if Shift = [] then Exit; // special processing is not required if ssCtrl in Shift then begin { make changes symmetrical } with OldLocation do begin cx := (Left + Right) / 2; cy := (Top + Bottom) / 2; w := Right - Left; h := Bottom - Top; end; with NewLocation do begin nw := w / 2; nh := h / 2; case DragState of dsSizeL: nw := cx - Left; dsSizeT: nh := cy - Top; dsSizeR: nw := Right - cx; dsSizeB: nh := Bottom - cy; dsSizeTL: begin nw := cx - Left; nh := cy - Top; end; dsSizeTR: begin nw := Right - cx; nh := cy - Top; end; dsSizeBL: begin nw := cx - Left; nh := Bottom - cy; end; dsSizeBR: begin nw := Right - cx; nh := Bottom - cy; end; end; if nw < 10 then nw := 10; if nh < 10 then nh := 10; Left := cx - nw; Right := cx + nw; Top := cy - nh; Bottom := cy + nh; end; end; end; {This function is not required, but might be useful at some point.} procedure TufrmImgMarkup.mnFlattenClick(Sender: TObject); var B: TBitmap32; W, H: Integer; begin { deselect everything } Selection := nil; W := ImgView.Bitmap.Width; H := ImgView.Bitmap.Height; { Create a new bitmap to store a flattened image } B := TBitmap32.Create; try B.SetSize(W, H); ImgView.PaintTo(B, Rect(0, 0, W, H)); { destroy all the layers of the original image... } ImgView.Layers.Clear; RBLayer := nil; // note that RBLayer reference is destroyed here as well. // The rubber band will be recreated during the next // SetSelection call. Alternatively, you can delete // all the layers except the rubber band. { ...and overwrite it with the flattened one } ImgView.Bitmap := B; finally B.Free; end; end; {procedure TufrmImgMarkup.mnPrintClick(Sender: TObject); var B: TBitmap32; W, H: Integer; R: TRect; function GetCenteredRectToFit(const src, dst: TRect): TRect; var srcWidth, srcHeight, dstWidth, dstHeight, ScaledSide: Integer; begin with src do begin srcWidth := Right - Left; srcHeight := Bottom - Top; end; with dst do begin dstWidth := Right - Left; dstHeight := Bottom - Top; end; if (srcWidth = 0) or (srcHeight = 0) then exit; if srcWidth / srcHeight > dstWidth / dstHeight then begin ScaledSide := Round(dstWidth * srcHeight / srcWidth); with Result do begin Left := dst.Left; Top := dst.Top + (dstHeight - ScaledSide) div 2; Right := dst.Right; Bottom := Top + ScaledSide; end; end else begin ScaledSide := Round(dstHeight * srcWidth / srcHeight); with Result do begin Left := dst.Left + (dstWidth - ScaledSide) div 2; Top := dst.Top; Right := Left + ScaledSide; Bottom := dst.Bottom; end; end; end; begin //deselect everything Selection := nil; W := ImgView.Bitmap.Width; H := ImgView.Bitmap.Height; //Create a new bitmap to store a flattened image B := TBitmap32.Create; Screen.Cursor := crHourGlass; try B.SetSize(W, H); ImgView.PaintTo(B, Rect(0, 0, W, H)); Printer.BeginDoc; Printer.Title := 'Image View Layers Example'; B.Resampler := TLinearResampler.Create(B); R := GetCenteredRectToFit(Rect(0, 0, W, H), Rect(0, 0, Printer.PageWidth, Printer.PageHeight)); B.TileTo(Printer.Canvas.Handle, R, Rect(0, 0, W, H)); Printer.EndDoc; finally B.Free; Screen.Cursor := crDefault; end; end; } procedure TufrmImgMarkup.ImgViewMouseWheelUp(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); var s: Single; begin if (ActiveControl.Name = 'jvcolcmbAnnColor') or (ActiveControl.Name = 'jvicbShapes') then begin Handled := True; Exit; end; s := ImgView.Scale / 1.1; if s < 0.1 then s := 0.1; ImgView.Scale := s; cmbScale.Text := IntToStr(Round(s * 100)) + '%'; end; procedure TufrmImgMarkup.ImgViewMouseWheelDown(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); var s: Single; begin if (ActiveControl.Name = 'jvcolcmbAnnColor') or (ActiveControl.Name = 'jvicbShapes') then begin Handled := True; Exit; end; s := ImgView.Scale * 1.1; if s > 10 then s := 10; ImgView.Scale := s; cmbScale.Text := IntToStr(Round(s * 100)) + '%'; end; procedure TufrmImgMarkup.cbOptRedrawClick(Sender: TObject); begin end; { TPositionedLayerWithXML } constructor TPositionedLayerWithXML.Create(ALayerCollection: TLayerCollection); begin inherited Create(ALayerCollection); Color := clRed; AnnTitle := '[Annotation title]'; AnnText := '

[Annotation detail]

'; DrawShape := True; //default end; procedure TufrmImgMarkup.aNewAreaExecute(Sender: TObject); var L: TPositionedLayerWithXML; begin L := CreatePositionedLayer; L.OnPaint := PaintSimpleDrawingHandler; L.Tag := 1; Selection := L; ufrmAreaList.uclbAreaList.Items.AddObject(L.AnnTitle, L); ufrmAreaList.uclbAreaList.Checked[ufrmAreaList.uclbAreaList.Items.Count-1] := True; end; procedure TufrmImgMarkup.aDeleteAreaExecute(Sender: TObject); var ALayer: TPositionedLayerWithXML; wsMessidge: WideString; begin if Selection <> nil then begin wsMessidge := WideFormat(umsgConfirmDeleteLayer.Caption, [TPositionedLayerWithXML(Selection).AnnTitle]); if WideMessageDlg(wsMessidge, mtWarning, mbYesNoCancel, 0) = mrYes then begin ALayer := Selection; //Update the list box ufrmAreaList.FindAndDeleteItem(ALayer); Selection := nil; ALayer.Free; DocModified := True; end; end; end; procedure TufrmImgMarkup.aeMainIdle(Sender: TObject; var Done: Boolean); var LayerSelected: Boolean; IsEdit: Boolean; HasSelection: Boolean; HasText: Boolean; boolCanUndo: Boolean; begin LayerSelected := (Selection is TPositionedLayerWithXML); aDeleteArea.Enabled := LayerSelected; aChangeAreaColor.Enabled := LayerSelected; jvcolcmbAnnColor.Enabled := LayerSelected; jvicbShapes.Enabled := LayerSelected; ueAnnTitle.Enabled := LayerSelected; umAnnText.Enabled := LayerSelected; IsEdit := ((Screen.ActiveForm.ActiveControl is TTntEdit) or (Screen.ActiveForm.ActiveControl is TTntMemo)); if IsEdit then begin if (Screen.ActiveForm.ActiveControl is TTntEdit) then with (Screen.ActiveForm.ActiveControl as TTntEdit) do begin HasSelection := (SelLength > 0); boolCanUndo := CanUndo; HasText := (Length(Text) > 0); end; if (Screen.ActiveForm.ActiveControl is TTntMemo) then with (Screen.ActiveForm.ActiveControl as TTntMemo) do begin HasSelection := (SelLength > 0); boolCanUndo := CanUndo; HasText := (Length(Text) > 0); end; aUndo.Enabled := boolCanUndo; aCut.Enabled := HasSelection; aCopy.Enabled := HasSelection; aPaste.Enabled := Clipboard.HasFormat(CF_TEXT); aDelete.Enabled := HasSelection; aSelectAll.Enabled := HasText; end else begin aUndo.Enabled := False; aCut.Enabled := False; aCopy.Enabled := False; aPaste.Enabled := False; aDelete.Enabled := False; aSelectAll.Enabled := False; end; end; procedure TufrmImgMarkup.ImgViewKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState); begin if Key = VK_DELETE then aDeleteAreaExecute(aDeleteArea); end; procedure TufrmImgMarkup.ShowLayerData(PLXML: TPositionedLayerWithXML); begin if PLXML <> nil then begin ueAnnTitle.Text := PLXML.AnnTitle; umAnnText.Text := PLXML.AnnText; jvcolcmbAnnColor.ColorValue := PLXML.Color; jvicbShapes.ItemIndex := PLXML.AreaShape; end; end; procedure TufrmImgMarkup.StashLayerData(PLXML: TPositionedLayerWithXML); begin if PLXML <> nil then begin PLXML.AnnTitle := ueAnnTitle.Text; PLXML.AnnText := umAnnText.Text; //Update the layer list if it's still in existence -- it might have been destroyed //during shutdown if ufrmAreaList.uclbAreaList <> nil then ufrmAreaList.FindAndSetTitle(PLXML, ueAnnTitle.Text); end; end; procedure TufrmImgMarkup.ClearAnnotationData; begin ueAnnTitle.Text := ''; umAnnText.Text := ''; end; procedure TufrmImgMarkup.SetDocModified(bVal: Boolean); begin //Possibly pointless function at the moment, but it may be useful later to do other //processing when marking the doc as unchanged or dirty. if bVal <> fDocModified then begin fDocModified := bVal; end; end; procedure TufrmImgMarkup.ueAnnTitleChange(Sender: TObject); begin DocModified := True; //Update the layer list form to show the changing title if Selection <> nil then ufrmAreaList.FindAndSetTitle(Selection, ueAnnTitle.Text); end; procedure TufrmImgMarkup.TntFormShow(Sender: TObject); begin FFormStateSaver := TFormStateSaver.Create(Self, True); FRecentFiles := TRecentFiles.Create(Self, umnRecentFiles, OpenRecent); SplashAbout := TSplashAbout.Create; SplashAbout.ShowSplash(imgSplash.Picture.Bitmap, 3, BoundsRect); ufrmPreferences.ReadSettingsFromDisk; //If user has configured the preference to reload the last file, try to do so if ufrmPreferences.ucbReloadLastFileOnStartup.Checked then if FileExists(FRecentFiles.LastFile) then OpenFile(FRecentFiles.LastFile); end; function TPositionedLayerWithXML.GetCenterPoint: TPoint; begin Result.X := Round(Location.Left + ((Location.Right - Location.Left)/2)); Result.Y := Round(Location.Top + ((Location.Bottom - Location.Top)/2)); end; function TPositionedLayerWithXML.ReportDivTag(LinkedID, TypeString: WideString): WideString; var OutAnnText: WideString; begin {TODO: This function needs to be made considerably more sophisticated, by the addition of a parsing system to detect whether a user can or wants to handle their own p tags inside the AnnText element or not. The core plan for this algorithm has been written, but there is no implementation yet.} Result := WTagElement(AnnTitle, 'head') + #13#10; OutAnnText := WideTrim(AnnText); //Add a p tag only if the trimmed text doesn't begin with one. if (Copy(AnnText, 1, 3) <> '

') and (Copy(AnnText, 1, 3) <> '

' + Result + ''; end; function TPositionedLayerWithXML.ReportRectTag(id: WideString; IncludeNS: Boolean): WideString; begin Result := ''); end; { TImgDom } procedure TImgDom.ClearAll; begin XMLFilePath := ''; CurrXMLDoc.Clear; fCurrDocTeiHeaderNode := nil; fCurrDocWrapperNode := nil; ImagePath := ''; ImageTitle := ''; ImageDesc := ''; end; constructor TImgDom.Create(LinkedIV: TImgView32); begin //Create DOM parsing components DomImpl := TDomImplementation.Create(nil); XmlToDomParser := TXmlToDomParser.Create(nil); DomToXmlParser := TDomToXmlParser.Create(nil); //Set up some properties XmlToDomParser.DOMImpl := DomImpl; DomToXmlParser.DOMImpl := DomImpl; CurrXMLDoc := TDomDocument.Create(DomImpl); //Create a node filter for finding the imt markup node in a document fWrapperNodeFilter := TTagAndAttributeDomNodeFilter.Create([ntElement_Node], 'div', 'type', WrapperTypeString, False); if LinkedIV <> nil then LinkedImgView := LinkedIV; //Create an SVG node filter fSVGNodeFilter := TTagDomNodeFilter.Create([ntElement_Node], 'svg', False); //Create a filter for finding rect elements fRectNodeFilter := TTagDomNodeFilter.Create([ntElement_Node], 'rect', False); //Create a filter for finding annotation layers fLayerNodeFilter := TTagAndAttributeDomNodeFilter.Create([ntElement_Node], 'div', 'type', LayerTypeString, False); //Create a filter for finding allowed subnodes of layer divs fAnnotationContentFilter := TAnnotationContentFilter.Create([ntElement_Node, ntComment_Node], False); end; procedure TImgDom.CreateTeiHeader; begin //Create content for the teiHeader tag if there is no content already if Length(teiHeader) < 10 then begin teiHeader := teiHeaderOpen + ImageTitle + teiHeaderClose; end; end; destructor TImgDom.Destroy; begin //Destroy DOM parsing components FreeAndNil(DomImpl); FreeAndNil(XmlToDomParser); FreeAndNil(DomToXmlParser); FreeAndNil(fWrapperNodeFilter); FreeAndNil(fSVGNodeFilter); FreeAndNil(fRectNodeFilter); FreeAndNil(fLayerNodeFilter); FreeAndNil(fAnnotationContentFilter); inherited; end; function TImgDom.LoadPersistentXMLDocument(FilePath: WideString): Boolean; var elWrapper, elSVG, elImage, elImageTitle, elImageDesc, elRect, elLayerDiv, elAnnTitle: TDomElement; NodeList: TDomNodeList; ndAnnText: TDomNode; WrapperIterator, SVGIterator, RectIterator, LayerIterator: TDomNodeIterator; LayerContentWalker: TDomTreeWalker; NewLayer: TPositionedLayerWithXML; x, y, width, height: integer; wsTemp: WideString; i: integer; wsTempID: WideString; begin //Namespace handling is still messy with XDOM, so here I'm using a standard //TDomDocument and treating namespace prefixes as part of the tag or attribute name. //This is a rewrite of the original LoadXMLDocument function using persistent objects //so that the file can be written back out again with any extra bits added outside //this application preserved intact. Result := False; CurrXMLDoc.Clear; try CurrXMLDoc := XMLToDomParser.FileToDom(FilePath); //If no exception, we can store the file path XMLFilePath := FilePath; //First, get the Wrapper node and store a reference to it WrapperIterator := TDomNodeIterator.Create(CurrXMLDoc, [ntElement_Node], fWrapperNodeFilter, False); try fCurrDocWrapperNode := WrapperIterator.NextNode; finally WrapperIterator.Free; end; //Bail completely if no wrapper node if fCurrDocWrapperNode = nil then begin //TODO: add reporting and error-handling here. Exit; end; //Set the ImgDom's ID field based on the ID of the wrapper node //TODO: Make sure this works, since we're now using xml:id ID := TDomElement(fCurrDocWrapperNode).GetAttributeNormalizedValue('xml:id'); SVGIterator := TDomNodeIterator.Create(fCurrDocWrapperNode, [ntElement_Node], fSVGNodeFilter, False); try elSVG := TDomElement(SVGIterator.NextNode); finally SVGIterator.Free; end; //Bail completely if no SVG node if elSVG = nil then begin //TODO: add reporting and error-handling here. Exit; end; //Get the first image element in the SVG tag if elSVG.GetElementsByTagName('image').Length > 0 then begin elImage := TDomElement(elSVG.GetElementsByTagName('image').item(0)); //Now get its href attribute value ImagePath := elImage.GetAttributeNormalizedValue('xlink:href'); if WGetFullPathFromRelative(XMLFilePath, ImagePath, wsTemp) = True then begin ImagePath := wsTemp; //Load the image LinkedImgView.Bitmap.Clear; if FileExists(ImagePath) then LinkedImgView.Bitmap.LoadFromFile(ImagePath); end else begin ImagePath := ''; //Missing image will be handled when trying to display it end; end; //Reset the id if it's nothing if Length(ID) < 3 then if ExtractFileName(ImagePath) <> '' then begin wsTempID := ExtractFileName(ImagePath); wsTempID := ChangeFileExt(wsTempID, ''); if not IsXMLNCName(wsTempID) then begin if ufrmXMLUtilities.MakeXMLNCName(wsTempID) then ID := wsTempID else ID := 'imt_unidentified_image'; end else begin ID := wsTempID; end; end else begin ID := 'imt_unidentified_image'; end; //Get the image title if elSVG.GetElementsByTagName('title').Length > 0 then begin elImageTitle := TDomElement(elSVG.GetElementsByTagName('title').item(0)); ImageTitle := elImageTitle.TextContent; end; if elSVG.GetElementsByTagName('desc').Length > 0 then begin elImageDesc := TDomElement(elSVG.GetElementsByTagName('desc').item(0)); ImageDesc := elImageDesc.TextContent; end; //Get the rect elements and iterate through them RectIterator := TDomNodeIterator.Create(elSVG, [ntElement_Node], fRectNodeFilter, False); try elRect := TDomElement(RectIterator.NextNode); while elRect <> nil do begin wsTemp := elRect.GetAttributeNormalizedValue('svg:id'); LayerIterator := TDomNodeIterator.Create(elSVG.ParentNode, [ntElement_Node], fLayerNodeFilter, False); elLayerDiv := TDomElement(LayerIterator.NextNode); while (elLayerDiv <> nil) and (elLayerDiv.GetAttributeNormalizedValue('n') <> wsTemp) do elLayerDiv := TDomElement(LayerIterator.NextNode); if elLayerDiv.GetAttributeNormalizedValue('n') = wsTemp then //We have a match; we can read the rect properties and the div data to //create an annotation layer and stash the annotation data begin //Read the position data for the annotation area x := StrToIntDef(elRect.GetAttributeNormalizedValue('x'), 100); y := StrToIntDef(elRect.GetAttributeNormalizedValue('y'), 100); width := StrToIntDef(elRect.GetAttributeNormalizedValue('width'), 100); height := StrToIntDef(elRect.GetAttributeNormalizedValue('height'), 100); //Create the new layer //TODO -1 -oMartin: THE CreatePositionedLayer FUNCTION SHOULD PROBABLY MOVE TO BECOME A MEMBER OF //TImgDom; THE CURRENT STRUCTURE IS NOT CLEANLY SEPARATED. SAME MAY APPLY TO //PaintSimpleDrawingHandler. NewLayer := ufrmImgMarkup.CreatePositionedLayer; NewLayer.OnPaint := ufrmImgMarkup.PaintSimpleDrawingHandler; NewLayer.Tag := 1; NewLayer.Location := FloatRect(x, y, (width+x), (height+y)); NewLayer.Color := WebColorToWinColorDef(elRect.GetAttributeNormalizedValue('color'), clRed); NewLayer.AreaShape := StrToIntDef(elRect.GetAttributeNormalizedValue('style'), 0); LinkedImgView.Invalidate; //Now read the annotation data and set it. //Changed for version 0.9.1.0: allow any tags, not just p tags if elLayerDiv.GetElementsByTagName('head').Length > 0 then begin elAnnTitle := TDomElement(elLayerDiv.getElementsByTagName('head').item(0)); if elAnnTitle <> nil then NewLayer.AnnTitle := elAnnTitle.TextContent; end; LayerContentWalker := CurrXMLDoc.CreateTreeWalker(elLayerDiv, [ntElement_Node, ntComment_Node], fAnnotationContentFilter, False); try NewLayer.AnnText := ''; if LayerContentWalker.CurrentNode.HasChildNodes then begin ndAnnText := LayerContentWalker.FirstChild; while ndAnnText <> nil do begin if not (ndAnnText = elAnnTitle) then begin wsTemp := ''; DomToXMLParser.WriteToWideString(ndAnnText, wsTemp); if wsTemp[1] = WideChar($feff) then Delete(wsTemp, 1, 1); NewLayer.AnnText := NewLayer.AnnText + wsTemp; end; ndAnnText := LayerContentWalker.NextSibling; end; end; finally CurrXMLDoc.FreeTreeWalker(LayerContentWalker); end; elLayerDiv := TDomElement(LayerIterator.NextNode); //Add this item into the layer list //TODO -oMartin -5: IF CreatePositionedLayer is moved into TImgDom, then this functionality //will fit more neatly in. ufrmAreaList.uclbAreaList.AddItem(NewLayer.AnnTitle, NewLayer); ufrmAreaList.uclbAreaList.Checked[ufrmAreaList.uclbAreaList.Items.Count-1] := True; end; elRect := TDomElement(RectIterator.NextNode); end; finally RectIterator.Free; end; //Read the teiHeader code teiHeader := ''; wsTemp := ''; if CurrXMLDoc.GetElementsByTagName('teiHeader').Length > 0 then begin fCurrDocTeiHeaderNode := TDomElement(CurrXMLDoc.GetElementsByTagName('teiHeader').item(0)); try DomToXMLParser.WriteToWideString(fCurrDocTeiHeaderNode, wsTemp); //A bug in XDOM may preface this WideString with a BOM of FEFF, so we need to get rid of it if wsTemp[1] = WideChar($feff) then Delete(wsTemp, 1, 1); teiHeader := WideTrim(wsTemp); // ShowMessage(teiHeader); except CreateTeiHeader; end; end else begin CreateTeiHeader; end; Result := True; except //TODO: Add exception handling here! end; end; function TImgDom.LoadXMLDocument(FilePath: WideString): Boolean; var elSVG, elImage, elImageTitle, elImageDesc, elRect, elDiv, elAnnTitle, elAnnText, elTeiHeader: TDomElement; NodeList: TDomNodeList; DomToXMLParser: TDomToXMLParser; RectIterator: TDomNodeIterator; RectFilter: TRectDomNodeFilter; DivIterator: TDomNodeIterator; DivFilter: TTagAndAttributeDomNodeFilter; NewLayer: TPositionedLayerWithXML; x, y, width, height: integer; Temp: WideString; i: integer; begin //Namespace handling is still messy with XDOM, so here I'm using a standard //TDomDocument and treating namespace prefixes as part of the tag or attribute name. Result := False; XMLDoc := TDomDocument.Create(DomImpl); try XMLDoc := XMLToDomParser.FileToDom(FilePath); //If no exception, we can store the file path XMLFilePath := FilePath; //ShowMessage(IntToStr(XMLDoc.GetElementsByTagName('svg:svg').Length)); //In parts of function, I've used simple loops and lists rather than node iterators //or treewalkers; with small files (as these are likely to be), and when the //structure is predictable, I think it's probably simpler and quicker, but //this code may be rewritten with more sophisticated parsing later. //First, try to resolve that file path and load the image //Get the first SVG element elSVG := nil; if XMLDoc.GetElementsByTagName('svg').Length > 0 then begin elSVG := TDomElement(XMLDoc.GetElementsByTagName('svg').item(0)); //Get its first image element if elSVG.GetElementsByTagName('image').Length > 0 then begin elImage := TDomElement(elSVG.GetElementsByTagName('image').item(0)); //Now get its href attribute value ImagePath := elImage.GetAttributeNormalizedValue('xlink:href'); if WGetFullPathFromRelative(XMLFilePath, ImagePath, Temp) = True then begin ImagePath := Temp; //Load the image LinkedImgView.Bitmap.Clear; if FileExists(ImagePath) then LinkedImgView.Bitmap.LoadFromFile(ImagePath); end else begin ImagePath := ''; //Missing image will be handled when trying to display it end; end; //Get the image title if elSVG.GetElementsByTagName('title').Length > 0 then begin elImageTitle := TDomElement(elSVG.GetElementsByTagName('title').item(0)); ImageTitle := elImageTitle.TextContent; end; if elSVG.GetElementsByTagName('desc').Length > 0 then begin elImageDesc := TDomElement(elSVG.GetElementsByTagName('desc').item(0)); ImageDesc := elImageDesc.TextContent; end; end; //Read the id attribute and check it against the filename; if correct, //set the ID field of ImgDom. ID := ''; NodeList := XMLDoc.GetElementsByTagName('div'); if NodeList.Length > 0 then begin i := 0; while (i nil then begin DomToXMLParser := TDomToXMLParser.Create(nil); try DomToXMLParser.DomImpl := XMLDoc.DomImplementation; DomToXMLParser.UseByteOrderMark := False; RectFilter := TRectDomNodeFilter.Create([ntElement_Node], False); RectIterator := TDomNodeIterator.Create(elSVG, [ntElement_Node], RectFilter, False); DivFilter := TTagAndAttributeDomNodeFilter.Create([ntElement_Node], 'div', 'type', LayerTypeString, False); elRect := TDomElement(RectIterator.NextNode); while elRect <> nil do begin Temp := elRect.GetAttributeNormalizedValue('svg:id'); DivIterator := TDomNodeIterator.Create(elSVG.ParentNode, [ntElement_Node], DivFilter, False); elDiv := TDomElement(DivIterator.NextNode); while (elDiv <> nil) and (elDiv.GetAttributeNormalizedValue('n') <> Temp) do elDiv := TDomElement(DivIterator.NextNode); if elDiv.GetAttributeNormalizedValue('n') = Temp then //We have a match; we can read the rect properties and the div data to //create an annotation layer and stash the annotation data begin //Read the position data for the annotation area x := StrToIntDef(elRect.GetAttributeNormalizedValue('x'), 0); y := StrToIntDef(elRect.GetAttributeNormalizedValue('y'), 0); width := StrToIntDef(elRect.GetAttributeNormalizedValue('width'), 0); height := StrToIntDef(elRect.GetAttributeNormalizedValue('height'), 0); //Create the new layer //TODO -1 -oMartin: THE CreatePositionedLayer FUNCTION SHOULD PROBABLY MOVE TO BECOME A MEMBER OF //TImgDom; THE CURRENT STRUCTURE IS NOT CLEANLY SEPARATED. SAME MAY APPLY TO //PaintSimpleDrawingHandler. NewLayer := ufrmImgMarkup.CreatePositionedLayer; NewLayer.OnPaint := ufrmImgMarkup.PaintSimpleDrawingHandler; NewLayer.Tag := 1; NewLayer.Location := FloatRect(x, y, (width+x), (height+y)); NewLayer.Color := WebColorToWinColorDef(elRect.GetAttributeNormalizedValue('color'), clRed); NewLayer.AreaShape := StrToIntDef(elRect.GetAttributeNormalizedValue('style'), 0); LinkedImgView.Invalidate; //Now read the annotation data and set it. if elDiv.GetElementsByTagName('head').Length > 0 then begin elAnnTitle := TDomElement(elDiv.getElementsByTagName('head').item(0)); if elAnnTitle <> nil then NewLayer.AnnTitle := elAnnTitle.TextContent; end; if elDiv.GetElementsByTagName('p').Length > 0 then begin Temp := ''; NewLayer.AnnText := ''; for i := 0 to elDiv.GetElementsByTagName('p').Length - 1 do begin DomToXMLParser.WriteToWideString(elDiv.GetElementsByTagName('p').item(i), Temp); if Temp[1] = WideChar($feff) then Delete(Temp, 1, 1); NewLayer.AnnText := NewLayer.AnnText + Temp; Temp := ''; end; end; //Add this item into the layer list //TODO -oMartin -5: IF CreatePositionedLayer is moved into TImgDom, then this functionality //will fit more neatly in. ufrmAreaList.uclbAreaList.AddItem(NewLayer.AnnTitle, NewLayer); ufrmAreaList.uclbAreaList.Checked[ufrmAreaList.uclbAreaList.Items.Count-1] := True; end; elRect := TDomElement(RectIterator.NextNode); end; finally DomToXMLParser.Free; end; end; //Read the teiHeader code teiHeader := ''; Temp := ''; if XMLDoc.GetElementsByTagName('teiHeader').Length > 0 then begin elTeiHeader := TDomElement(XMLDoc.GetElementsByTagName('teiHeader').item(0)); DomToXMLParser := TDomToXMLParser.Create(nil); try try DomToXMLParser.DomImpl := XMLDoc.DomImplementation; DomToXMLParser.UseByteOrderMark := False; DomToXMLParser.WriteToWideString(elTeiHeader, Temp); //A bug in XDOM prefaces this WideString with a BOM of FEFF, so we need to get rid of it if Temp[1] = WideChar($feff) then Delete(Temp, 1, 1); teiHeader := Temp; // ShowMessage(teiHeader); except CreateTeiHeader; end; finally DomToXMLParser.Free; end; end else CreateTeiHeader; Result := True; finally XMLDoc.Free; end; end; function TImgDom.SaveToPersistentXMLFile: Boolean; var NewHeaderNode, NewWrapperNode: TDomNode; Wrapper: WideString; WrapperIterator: TDomNodeIterator; Stream: TFileStream; begin //This function writes the current teiHeader and annotation data //to an existing document in memory. //TODO: Check that the document is there and usable (HOW??? Will this work???) //If there's no document, then create a new one if (CurrXMLDoc = nil) or (CurrXMLDoc.DocumentElement = nil) then begin SaveToXMLFile; Exit; end; //If the document is screwed up if (CurrXMLDoc.DocumentElement.NodeName <> 'TEI') or (fCurrDocWrapperNode = nil) then begin SaveToXMLFile; //TODO: In this case, do we need to reload the fresh document from file? There is no //possible extra data in it unless it's modified outside of the program, so actually //it probably doesn't matter, but give it some thought. For the moment, we'll set //the doc to nil. CurrXMLDoc.Clear; Exit; end; //Create a document fragment node from the teiHeader XML source NewHeaderNode := TDomDocumentFragment.Create(CurrXMLDoc); NewHeaderNode := XMLToDomParser.ParseWideString(WideTrim(teiHeader), '', '', NewHeaderNode); CurrXMLDoc.DocumentElement.ReplaceChild(NewHeaderNode, fCurrDocTeiHeaderNode); fCurrDocTeiHeaderNode := CurrXMLDoc.GetElementsByTagName('teiHeader').Item(0); //Create the XML we want to write out to the wrapper node Wrapper := CreateWrapper; //Create a node from it NewWrapperNode := TDomDocumentFragment.Create(CurrXMLDoc); NewWrapperNode := XMLToDomParser.ParseWideString(Wrapper, '', '', NewWrapperNode); fCurrDocWrapperNode.ParentNode.ReplaceChild(NewWrapperNode, fCurrDocWrapperNode); //Set the wrapper pointer to point to the new node WrapperIterator := TDomNodeIterator.Create(CurrXMLDoc, [ntElement_Node], fWrapperNodeFilter, False); try fCurrDocWrapperNode := WrapperIterator.NextNode; finally WrapperIterator.Free; end; //Now save the file if Length(XMLFilePath) > 4 then begin Stream := TFileStream.Create(XMLFilePath, fmCreate or fmShareExclusive); try DomToXMLParser.WriteToStream(CurrXMLDoc, 'UTF-8', Stream); finally Stream.Free; end; end; end; function TImgDom.CreateWrapper: WideString; var RectTags, DivTags: WideString; i: integer; begin //Create the image tag Result := ' nil then begin Result := Result + ' width="' + IntToStr(LinkedImgView.Bitmap.Width) + '"'; Result := Result + ' height="' + IntToStr(LinkedImgView.Bitmap.Height) + '"'; end; Result := Result + ' />' + #13#10; Result := Result + '' + ImageTitle + '' + ImageDesc + ''; RectTags := ''; DivTags := ''; //Create text element contents //First, get all the tags if LinkedImgView <> nil then with TImgView32(LinkedImgView) do begin if Layers.Count > 0 then for i := 0 to Layers.Count - 1 do if Layers[i] is TPositionedLayerWithXML then begin RectTags := RectTags + TPositionedLayerWithXML(Layers[i]).ReportRectTag(ID + '_'+ IntToStr(i), True) + #13#10; DivTags := DivTags + TPositionedLayerWithXML(Layers[i]).ReportDivTag(ID + '_'+ IntToStr(i), LayerTypeString) + #13#10; end; end; //Wrap the image and rects in an SVG tag Result := SVGOpener + Result + RectTags + SVGCloser; //Now add the series of TEI divs Result := Result + DivTags; Result := '

' + Result + '
'; end; function TImgDom.SaveToXMLFile: Boolean; var NewNode: TDomElement; OutXML: WideString; Temp: WideString; i: integer; begin //This function creates a new document and saves it. //Default Result := False; //Create headers OutXML := WUTF8Header + #13#10; //Don't include doctype for the moment; it makes validation difficult without a //working schema. // OutXML := OutXML + teiDocType + #13#10; //Set the ID ID := ExtractFileName(ImagePath); //Create header tag if necessary if Length(teiHeader) < 10 then CreateTeiHeader; //Get the wrapper div and contents Temp := CreateWrapper; //Wrap the XML basic tags Temp := WTagElement(Temp, 'body'); Temp := WTagElement(Temp, 'text'); OutXML := OutXML + TEISchemaOpener + teiHeader + Temp + TEICloser; if Length(XMLFilePath) > 4 then Result := WSaveStringToFileUTF8(XMLFilePath, OutXML); //Report success Result := True; end; procedure TufrmImgMarkup.StashImageData; begin ImgDom.ImageTitle := ueImageTitle.Text; ImgDom.ImageDesc := umImageDesc.Text; end; procedure TufrmImgMarkup.DisplayImageData; begin ueImageTitle.Text := ImgDom.ImageTitle; umImageDesc.Text := ImgDom.ImageDesc; StatusText := ImgDom.ImagePath; CaptionText := ImgDom.XMLFilePath; end; procedure TufrmImgMarkup.aSaveAsExecute(Sender: TObject); begin SaveFileAs; end; function TufrmImgMarkup.SaveFile: Boolean; begin Result := False; if FileExists(ImgDom.XMLFilePath) then begin Selection := nil; StashImageData; //Bugfix 27/10/05 ufrmAreaList.ResequenceLayers; // ImgDom.SaveToXMLFile; ImgDom.SaveToPersistentXMLFile; ufrmAreaList.SendUncheckedToBack; DocModified := False; FRecentFiles.AddNewFile(ImgDom.XMLFilePath); Result := CheckSavedDocument(ImgDom.XMLFilePath); end else begin Result := SaveFileAs; end; end; function TufrmImgMarkup.SaveFileAs: Boolean; begin Result := False; if udlgSaveFile.Execute then begin Selection := nil; StashImageData; ImgDom.XMLFilePath := udlgSaveFile.FileName; //Bugfix 27/10/05 ufrmAreaList.ResequenceLayers; // ImgDom.SaveToXMLFile; ImgDom.SaveToPersistentXMLFile; ufrmAreaList.SendUncheckedToBack; DocModified := False; FRecentFiles.AddNewFile(ImgDom.XMLFilePath); RefreshStatus; RefreshCaption; Result := CheckSavedDocument(ImgDom.XMLFilePath); end; end; procedure TufrmImgMarkup.aSaveExecute(Sender: TObject); begin SaveFile; end; procedure TufrmImgMarkup.aNewExecute(Sender: TObject); begin if DocModified and not CheckSaved then Exit; ClearAllData; with udlgLoadImage do if Execute then OpenImage(FileName); end; function TufrmImgMarkup.CheckSaved: Boolean; begin Result := False; if DocModified then begin case WideMessageDlg(umsgSaveFileOrNot.Caption, mtWarning, mbYesNoCancel, 0) of mrYes: Result := SaveFile; mrNo: Result := True; mrCancel: Result := False; end; end else begin Result := True; end; end; procedure TufrmImgMarkup.aImportImageExecute(Sender: TObject); begin if (not ImgView.Bitmap.Empty) or (ImgView.Layers.Count > 0) then begin case WideMessageDlg(umsgReplaceImage.Caption, mtWarning, mbYesNoCancel, 0) of mrYes: begin if udlgLoadImage.Execute then try Screen.Cursor := crHourglass; try Application.ProcessMessages; ImgView.Bitmap.LoadFromFile(udlgLoadImage.FileName); //Bugfix March 8 2006: set the file location to the new image ImgDom.ImagePath := udlgLoadImage.FileName; except WideMessageDlg(umsgUnableToLoadImage.Caption, mtWarning, [mbOK], 0); end; finally Screen.Cursor := crDefault; end; end; mrNo: aNewExecute(aNew); mrCancel: Exit; end; end else begin aNewExecute(aNew); end; end; procedure TufrmImgMarkup.aOpenExecute(Sender: TObject); begin if DocModified and not CheckSaved then Exit; if udlgOpenFile.Execute then OpenFile(udlgOpenFile.FileName); end; procedure TufrmImgMarkup.OpenFile(TheFileName: WideString); begin Screen.Cursor := crHourglass; try //First clear existing data ClearAllData; //TODO 5 -oMartin: Check the file to see if it's a markup file, and warn if it isn't // ImgDom.LoadXMLDocument(TheFileName); ImgDom.LoadPersistentXMLDocument(TheFileName); DisplayImageData; DocModified := False; FRecentFiles.AddNewFile(TheFileName); finally Screen.Cursor := crDefault; end; end; procedure TufrmImgMarkup.ClearAllData; begin ufrmAreaList.uclbAreaList.Clear; ImgDom.ClearAll; with ImgView do try Selection := nil; RBLayer := nil; Layers.Clear; Scale := 1; Bitmap.Clear; finally end; //MDH: Reset the scale value when loading a new image. cmbScale.Text := '100%'; DisplayImageData; end; function TImgDom.FindWrapperNode: TDomNode; begin end; { TRectDomNodeFilter } function TRectDomNodeFilter.acceptNode(const node: TdomNode): TdomFilterResult; begin if (Node.NodeType in fNodeType) and (Node.NodeName = 'rect') then Result := FILTER_ACCEPT else Result := FILTER_REJECT; end; constructor TRectDomNodeFilter.Create(nodeType: TDomWhatToShow; reject: Boolean); begin inherited Create; FReject := reject; FNodeType := nodeType; end; { TTagDomNodeFilter } function TTagDomNodeFilter.acceptNode(const node: TdomNode): TdomFilterResult; begin if (Node.NodeType in fNodeType) and (Node.NodeName = FTagName) then Result := FILTER_ACCEPT else Result := FILTER_REJECT; end; constructor TTagDomNodeFilter.Create(nodeType: TDomWhatToShow; TagName: WideString; reject: Boolean); begin inherited Create; FReject := reject; FNodeType := nodeType; FTagName := TagName; end; { TTagAndAttributeDomNodeFilter } function TTagAndAttributeDomNodeFilter.acceptNode( const node: TdomNode): TdomFilterResult; begin Result := FILTER_REJECT; //Default if Node.NodeType in fNodeType then if Node.NodeName = fTagName then if Node.NodeType in [ntElement_Node] then if TDomElement(Node).HasAttribute(fAttributeName) then if TDomElement(Node).GetAttributeNormalizedValue(fAttributeName) = fAttributeValue then Result := FILTER_ACCEPT; end; constructor TAnnotationContentFilter.Create(nodeType: TDomWhatToShow; reject: Boolean); begin inherited Create; FReject := reject; FNodeType := nodeType; end; function TAnnotationContentFilter.AcceptNode( const node: TdomNode): TdomFilterResult; const OKNodeNames: Array[0..49] of WideString = ('ab', 'altGrp', 'argument', 'bibl', 'biblFull', 'biblItem', 'biblStruct', 'byline', 'certainty', 'cit', 'closer', 'dateline', 'div', 'divGen', 'docAuthor', 'docDate', 'epigraph', 'fLib', 'figure', 'fs', 'fvLib', 'fw', 'gap', 'index', 'interp', 'interpGrp', 'join', 'joinGrp', 'l', 'label', 'lg', 'linkGrp', 'list', 'listBibl', 'note', 'opener', 'p', 'q', 'quote', 'respons', 'salute', 'sp', 'span', 'spanGrp', 'signed', 'sp', 'stage', 'table', 'timeline', 'trailer'); function TagIsAllowed(TagName: WideString): Boolean; var i: integer; begin Result := False; for i := Low(OKNodeNames) to High(OKNodeNames) do if TagName = OKNodeNames[i] then begin Result := True; Break; end; end; begin Result := FILTER_REJECT; //Default if Node.NodeType in fNodeType then if Node.NodeType in [ntComment_Node] then Result := FILTER_ACCEPT else if Node.NodeType in [ntElement_Node] then if TagIsAllowed(Node.NodeName) then Result := FILTER_ACCEPT; end; constructor TTagAndAttributeDomNodeFilter.Create(nodeType: TDomWhatToShow; TagName, AttributeName, AttributeValue: WideString; Reject: Boolean); begin inherited Create; fNodeType := nodeType; fTagName := TagName; fAttributeName := AttributeName; fAttributeValue := AttributeValue; end; procedure TufrmImgMarkup.TntFormCloseQuery(Sender: TObject; var CanClose: Boolean); begin if DocModified and not CheckSaved then CanClose := False else FAppClosing := True; end; procedure TufrmImgMarkup.TntFormClose(Sender: TObject; var Action: TCloseAction); begin FreeAndNil(SplashAbout); FreeAndNil(FRecentFiles); FreeAndNil(FFormStateSaver); end; procedure TufrmImgMarkup.aTeiHeaderExecute(Sender: TObject); begin with ImgDom do begin if Length(teiHeader) < 10 then CreateTeiHeader; ufrmTeiHeader.umTeiHeader.Text := WideTrim(teiHeader); if ufrmTeiHeader.ShowModal = mrOK then if teiHeader <> ufrmTeiHeader.umTeiHeader.Text then begin teiHeader := WideTrim(ufrmTeiHeader.umTeiHeader.Text); DocModified := True; end; end; end; procedure TufrmImgMarkup.SetStatusText(const Value: WideString); var ShortName: TFileName; begin ShortName := MinimizeName(TFileName(Value), usbMain.Canvas, Width div 2); if usbMain.Panels[0].Text <> WideString(ShortName) then usbMain.Panels[0].Text := WideString(ShortName); end; function TufrmImgMarkup.GetStatusText: WideString; begin Result := usbMain.Panels[0].Text; end; function TufrmImgMarkup.GetCaptionText: WideString; begin Result := Caption; end; procedure TufrmImgMarkup.SetCaptionText(const Value: WideString); var ShortName: TFileName; begin ShortName := MinimizeName(TFileName(Value), Canvas, Width div 2); if Caption <> Application.Title + ': ' + WideString(ShortName) then if Length(ShortName) > 0 then Caption := Application.Title + ': ' + WideString(ShortName) else Caption := Application.Title + ': ' + umsgUntitled.Caption; end; procedure TufrmImgMarkup.RefreshCaption; begin if ImgDom <> nil then SetCaptionText(ImgDom.XMLFilePath); end; procedure TufrmImgMarkup.RefreshStatus; begin if ImgDom <> nil then SetStatusText(ImgDom.ImagePath); end; procedure TufrmImgMarkup.TntFormResize(Sender: TObject); begin //Set the size of the status bar panels usbMain.Panels[0].Width := (Width div 3)*2; //Refresh the file path readouts in case they need to be expanded or contracted RefreshStatus; RefreshCaption; end; procedure TufrmImgMarkup.ImgViewMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer; Layer: TCustomLayer); var P: TPoint; begin // get coordinates of the center of viewport P := ImgView.ControlToBitmap(Point(X,Y)); usbMain.Panels[1].Text := 'x: ' + IntToStr(P.X) + ', y: ' + IntToStr(P.Y); end; procedure TufrmImgMarkup.aShowAreaListExecute(Sender: TObject); begin if ufrmAreaList <> nil then begin if not ufrmAreaList.Showing then ufrmAreaList.Show; ufrmAreaList.BringToFront; end; end; procedure TufrmImgMarkup.umAnnTextChange(Sender: TObject); begin DocModified := True; end; {function TufrmImgMarkup.GetImgViewVScrollPos: integer; begin Result := Round(TImgViewAccess(ImgView).VScroll.Position); end; } {function TufrmImgMarkup.GetImgViewHScrollPos: integer; begin Result := Round(TImgViewAccess(ImgView).HScroll.Position); end; } procedure TufrmImgMarkup.aTranslateExecute(Sender: TObject); begin ufrmTranslate.ShowModal; end; procedure TufrmImgMarkup.OpenRecent(Sender: TObject; const FileName: WideString); begin OpenFile(FileName); end; procedure TufrmImgMarkup.umnTestClick(Sender: TObject); var ScaleFactor: Double; TestList: TTntStringList; begin TestList := TTntStringList.Create; TestList.Add(Application.ExeName); TestList.Add(ExtractFilePath(Application.ExeName) + 'ImageMarkup.ico'); TestList.Add(ExtractFilePath(Application.ExeName) + 'ImageMarkup.ixo'); TestList.Add(ExtractFilePath(Application.ExeName) + 'square.bmp'); TestList.Add(ExtractFilePath(Application.ExeName) + 'square.bomp'); if ufrmFileOverwriteConfirm.CheckForOverwrites(TestList) = True then ufrmFileOverwriteConfirm.ShowModal; TestList.Free; end; function TufrmImgMarkup.CheckWellFormed: integer; var WellFormed: Boolean; ErrorLineNum, ErrorLinePos: integer; ErrorLine: WideString; Messidge: WideString; IsTitleOK, IsTextOK: Boolean; begin Result := mrYes;//default return if FAppClosing then Exit; ErrorLine := ''; //This function checks the well-formedness of the annotation title and text IsTitleOK := ufrmXMLUtilities.CheckXMLWellFormedness('' + ueAnnTitle.Text + '', ErrorLineNum, ErrorLinePos, ErrorLine, False); if IsTitleOK = False then begin Messidge := WideFormat(umsgNotWellFormed.Caption, ['annotation title', IntToStr(ErrorLineNum), IntToStr(ErrorLinePos)]); if Length(ErrorLine) > 0 then Messidge := Messidge + #13#10#13#10 + ErrorLine; case WideMessageDlg(Messidge, mtWarning, mbYesNoCancel, 0) of mrYes: begin ueAnnTitle.Text := ufrmXMLUtilities.FixImproperlyNestedTags(ueAnnTitle.Text); IsTitleOK := ufrmXMLUtilities.CheckXMLWellFormedness('' + ueAnnTitle.Text + '', ErrorLineNum, ErrorLinePos, ErrorLine, False); end; mrCancel: begin Result := mrCancel; Exit; end; end; //end case end; ErrorLine := ''; IsTextOK := ufrmXMLUtilities.CheckXMLWellFormedness('
' + umAnnText.Text + '
', ErrorLineNum, ErrorLinePos, ErrorLine, False); if IsTextOK = False then begin Messidge := WideFormat(umsgNotWellFormed.Caption, ['annotation text', IntToStr(ErrorLineNum), IntToStr(ErrorLinePos)]); if Length(ErrorLine) > 0 then begin if Copy(ErrorLine, 1, 5) = '
' then ErrorLine := Copy(ErrorLine, 6, Length(ErrorLine)-5); if Copy(ErrorLine, Length(ErrorLine)-6, 6) = '
' then ErrorLine := Copy(ErrorLine, 1, Length(ErrorLine)-6); if Length(ErrorLine) > 0 then Messidge := Messidge + #13#10#13#10 + ErrorLine; end; case WideMessageDlg(Messidge, mtWarning, mbYesNoCancel, 0) of mrYes: begin umAnnText.Text := ufrmXMLUtilities.FixImproperlyNestedTags(umAnnText.Text); IsTextOK := ufrmXMLUtilities.CheckXMLWellFormedness('
' + umAnnText.Text + '
', ErrorLineNum, ErrorLinePos, ErrorLine, False); end; mrCancel: begin Result := mrCancel; Exit; end; end; //end case end; if (IsTitleOK and IsTextOK) then Result := mrYes else begin Result := mrNo; WideMessageDlg(umsgCannotSaveIllformedFile.Caption, mtWarning, [mbOK], 0); end; end; function TufrmImgMarkup.CheckSavedDocument(TheFileName: WideString): Boolean; var Line, LinePos: integer; Messidge: WideString; begin Result := ufrmXMLUtilities.CheckXMLFileWellFormedness(TheFileName, Line, LinePos, False); if Result = False then begin Messidge := WideFormat(umsgXMLFileNotWellFormed.Caption, [#13#10 + TheFileName + #13#10]); WideMessageDlg(Messidge, mtWarning, [mbOK], 0); end; end; procedure TufrmImgMarkup.aAboutExecute(Sender: TObject); begin SplashAbout.ShowAbout(imgSplash.Picture.Bitmap, BoundsRect, clWhite); end; function TufrmImgMarkup.MakeAnnTextWellFormed(InText: WideString): WideString; var wsTemp: WideString; ErrorLine: WideString; i, j: integer; begin //TODO: CHECK WHETHER THIS FUNCTION HAS BEEN SUPERCEDED!!!! IT'S PROBABLY OBSOLETE. //TODO: Finish coding the MakeAnnTextWellFormed function! {The purpose of this function is to force basic conformance with the schema on the annotation text. It can only be done in a very rudimentary way, unfortunately.} Result := InText; //default return //First check whether it's already OK. wsTemp := WideTrim(InText); if ufrmXMLUtilities.CheckXMLWellformedness(wsTemp, i, j, ErrorLine, False) = True then Exit; //First check whether everything is wrapped in a p tag. if not (Copy(wsTemp, 1, 3) = '

') then wsTemp := '

' + wsTemp; if not (Copy(wsTemp, Length(wsTemp) - 4, 4) = '

') then wsTemp := wsTemp + '

'; //Try this for well-formedness. If OK, then return it and exit. It's not perfect, //but it will survive file saving and loading. if ufrmXMLUtilities.CheckXMLWellformedness(wsTemp, i, j, ErrorLine, False) = True then begin Result := wsTemp; Exit; end; //If the above failed, then we must have some embedded tags which are //not correctly nested, which makes things more complicated. Start again //with the original text. wsTemp := WideTrim(InText); //DONE TO HERE!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! //If there are none, then we'll add them according to linebreaks. //If there are some p-tags, then try to parse out where they are, and add //any more that are required (long and complicated). //Now test for well-formedness. If well-formed, then return the result (success). //If not well-formed, then ---DO WHAT????? end; procedure TufrmImgMarkup.jvicbShapesChange(Sender: TObject); begin if Selection is TPositionedLayerWithXML then with TPositionedLayerWithXML(Selection) do if AreaShape <> jvicbShapes.ItemIndex then begin AreaShape := jvicbShapes.ItemIndex; ImgView.Invalidate; end; end; procedure TufrmImgMarkup.aChangeAreaColorExecute(Sender: TObject); begin if Selection is TPositionedLayerWithXML then begin dlgSpiralColor.Color := TPositionedLayerWithXML(Selection).Color; if dlgSpiralColor.Execute then begin jvcolcmbAnnColor.ColorValue := dlgSpiralColor.Color; TPositionedLayerWithXML(Selection).Color := dlgSpiralColor.Color; ImgView.Invalidate; end; end; end; procedure TufrmImgMarkup.jvcolcmbAnnColorChange(Sender: TObject); begin if Selection is TPositionedLayerWithXML then with TPositionedLayerWithXML(Selection) do if Color <> jvcolcmbAnnColor.Color then begin Color := jvcolcmbAnnColor.ColorValue; ImgView.Invalidate; end; end; procedure TufrmImgMarkup.aPreferencesExecute(Sender: TObject); begin ufrmPreferences.Show; end; procedure TufrmImgMarkup.TntFormMouseWheel(Sender: TObject; Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean); begin if (ActiveControl = jvicbShapes) or (ActiveControl = jvcolcmbAnnColor) then Handled := True; end; procedure TufrmImgMarkup.WMDROPFILES(var Message: TWMDROPFILES); var TotalFilesDropped: integer; Buffer: Array[0..255] of Char; begin TotalFilesDropped := DragQueryFile(Message.Drop, $FFFFFFFF, nil, 0); if TotalFilesDropped > 0 then //We only care about the first file begin DragQueryFile(Message.Drop, 0, @Buffer, sizeof(Buffer)); if FileExists(Buffer) then if ExtractFileExt(Buffer) = '.xml' then begin if DocModified and not CheckSaved then Exit; ClearAllData; try OpenFile(Buffer); except //TODO: Add a useful message here??? end; end; end; end; procedure TufrmImgMarkup.aCreateWebViewExecute(Sender: TObject); var OutputPath: WideString; FNameRoot: WideString; FShortName: WideString; FileList: TTntStringList; OutputXMLPath: WideString; OutputImagePath: WideString; OutputHTMLFilePath: WideString; SourceFilePath: WideString; ScaleFactor: Double; ImageDimensions: TPoint; XSLProc: TDomProcessingInstruction; DomImpl: TDomImplementation; DomDoc: TDomDocument; DomToXMLParser: TDomToXMLParser; XMLToDomParser: TXMLToDomParser; FileStream: TFileStream; El: TDomElement; ElName: WideString; NewEl: TDomElement; TextNode: TDomText; i: integer; FirefoxCommand: string; CommandLine: string; procedure ChangeXSLVarVal(El: TDomElement; NodeVal: WideString); begin while El.ChildNodes.Length > 0 do El.RemoveChild(El.ChildNodes.Item(0)); TextNode := TDomText.Create(DomDoc); TextNode.NodeValue := NodeVal; El.AppendChild(TextNode); end; begin //TODO: Code this function. //Confirm save changes if DocModified and not CheckSaved then Exit; //Get location for file save if udlgSaveFile.Execute then begin Screen.Cursor := crHourglass; try //Generate list of files that will be saved FileList := TTntStringList.Create; try SourceFilePath := WideExtractFilePath(Application.ExeName) + 'web_view\'; OutputPath := WideExtractFilePath(udlgSaveFile.FileName); FNameRoot := WideChangeFileExt(udlgSaveFile.FileName, ''); FShortName := WideChangeFileExt(WideExtractFileName(udlgSaveFile.FileName), ''); OutputImagePath := OutputPath + 'scaled_' + WideChangeFileExt(WideExtractFileName(ImgDom.ImagePath), '.jpg'); OutputHTMLFilePath := FNameRoot + '.htm'; FileList.Add(udlgSaveFile.FileName); FileList.Add(FNameRoot + '.css'); FileList.Add(FNameRoot + '.xsl'); FileList.Add(FNameRoot + '.js'); FileList.Add(OutputImagePath); FileList.Add(OutputHTMLFilePath); //Check whether they already exist, and if so, warn and allow the user //to decline to overwrite if ufrmFileOverwriteConfirm.CheckForOverwrites(FileList) then if ufrmFileOverwriteConfirm.ShowModal = mrCancel then Exit; //Create a scaled copy of the image file and copy it to location (always do this?) SaveScaledImage(ufrmWebViewPrefs.seMaxImageWidth.Value, OutputImagePath, ScaleFactor, ImageDimensions); //Copy js file to location if appropriate if ufrmFileOverwriteConfirm.CanOverwrite(FNameRoot + '.js') then WideCopyFile(SourceFilePath + 'web_view.js', FNameRoot + '.js', False); //Copy CSS file to location if appropriate if ufrmFileOverwriteConfirm.CanOverwrite(FNameRoot + '.css') then WideCopyFile(SourceFilePath + 'web_view.css', FNameRoot + '.css', False); //Copy XML file to location if appropriate //This is complex because we need to add a processing instruction if ufrmFileOverwriteConfirm.CanOverwrite(udlgSaveFile.FileName) then begin //Create DOM parsing components DomImpl := TDomImplementation.Create(nil); try XmlToDomParser := TXmlToDomParser.Create(nil); try DomToXmlParser := TDomToXmlParser.Create(nil); try //Set up some properties XmlToDomParser.DOMImpl := DomImpl; DomToXmlParser.DOMImpl := DomImpl; DomDoc := TDomDocument.Create(DomImpl); try //Load the file DomDoc := XMLToDomParser.FileToDom(ImgDom.XMLFilePath); //Add the stylesheet processing instruction XSLProc := TDomProcessingInstruction.Create(DomDoc, 'xml-stylesheet'); XSLProc.Data := 'type="text/xsl" href="' + FShortName + '.xsl"'; DomDoc.InsertBefore(XSLProc, DomDoc.FirstChild); //Save the file to the new location FileStream := TFileStream.Create(TFileName(udlgSaveFile.FileName), fmCreate or fmShareExclusive); try DomToXMLParser.WriteToStream(DomDoc, 'UTF-8', FileStream); finally FreeAndNil(FileStream); end; finally DomDoc.Free; end; finally FreeAndNil(DomToXmlParser); end; finally FreeAndNil(XmlToDomParser); end; finally FreeAndNil(DomImpl); end; end; //Load the XSL file from the source location, and modify it with the required info //before saving it again to the output location if ufrmFileOverwriteConfirm.CanOverwrite(FNameRoot + '.xsl') then begin //Create DOM parsing components DomImpl := TDomImplementation.Create(nil); try XmlToDomParser := TXmlToDomParser.Create(nil); try DomToXmlParser := TDomToXmlParser.Create(nil); try //Set up some properties XmlToDomParser.DOMImpl := DomImpl; DomToXmlParser.DOMImpl := DomImpl; DomDoc := TDomDocument.Create(DomImpl); try //Load the file DomDoc := XMLToDomParser.FileToDom(TFileName(SourceFilePath + 'web_view.xsl')); //Insert the nodes we need to add to customize the file //We need to insert them at the beginning of the file if DomDoc.GetElementsByTagName('xsl:variable').Length > 0 then for i := 0 to DomDoc.GetElementsByTagName('xsl:variable').Length-1 do begin El := TDomElement(DomDoc.GetElementsByTagName('xsl:variable').Item(i)); ElName := El.GetAttributeNormalizedValue('name'); if ElName = 'DocTitle' then ChangeXSLVarVal(El, ueImageTitle.Text); if ElName = 'DocFileName' then ChangeXSLVarVal(El, FShortName); if ElName = 'ImageWidth' then ChangeXSLVarVal(El, IntToStr(ImageDimensions.X)); if ElName = 'ImageHeight' then ChangeXSLVarVal(El, IntToStr(ImageDimensions.Y)); if ElName = 'ImageScaleFactor' then ChangeXSLVarVal(El, FloatToStr(ScaleFactor)); if ElName = 'ImageFileName' then ChangeXSLVarVal(El, WideExtractFileName(OutputImagePath)); end; //Save the file to the new location FileStream := TFileStream.Create(FNameRoot + '.xsl', fmCreate or fmShareExclusive); try DomToXMLParser.WriteToStream(DomDoc, 'UTF-8', FileStream); finally FreeAndNil(FileStream); end; finally DomDoc.Free; end; finally FreeAndNil(DomToXmlParser); end; finally FreeAndNil(XmlToDomParser); end; finally FreeAndNil(DomImpl); end; end; finally FreeAndNil(FileList); end; finally Screen.Cursor := crDefault; end; //Now create a hard-coded HTML file using libxml2 XSLT transform engine: mdhDoXSLTTransform(udlgSaveFile.FileName, FNameRoot + '.xsl', OutputHTMLFilePath); //Report results and offer to show the file to the user if WideMessageDlg(umsgShowInBrowser.Caption, mtConfirmation, [mbYes, mbNo], 0) = mrYes then begin //First try to find Firefox if FindFirefoxHTMLCommand(FirefoxCommand) = True then begin //Show the HTML file, not the XML, so // CommandLine := StringReplace(FirefoxCommand, '%1', udlgSaveFile.FileName, [rfReplaceAll]); CommandLine := StringReplace(FirefoxCommand, '%1', OutputHTMLFilePath, [rfReplaceAll]); ExecNewProcess(CommandLine, False); end else //Open in default browser LaunchFile(OutputHTMLFilePath); // OpenInternetExplorer(udlgSaveFile.FileName); //Don't use IE by default any more! end; end; end; function TufrmImgMarkup.SaveScaledImage(TargetWidth: integer; FilePath: WideString; var ScaleFactor: Double; var OutputDimensions: TPoint): Boolean; var OrigBitmap: TBitmap32; ScaledBitmap: TBitmap32; BmpOut: TBitmap; JPGOut: TJPEGImage; OrigCursor: TCursor; begin ScaleFactor := 1; //default Result := False; //default if ImgView.Bitmap <> nil then begin OrigCursor := Screen.Cursor; Screen.Cursor := crHourglass; try JPGOut := TJPEGImage.Create; try BmpOut := TBitmap.Create; try OrigBitmap := TBitmap32.Create; try //Load the current image file into the new bitmap OrigBitmap.LoadFromFile(ImgDom.ImagePath); //Figure out the correct scaling: don't expand, just reduce if OrigBitmap.Width > TargetWidth then begin ScaleFactor := TargetWidth / OrigBitmap.Width; //Scale the image ScaledBitmap := TBitmap32.Create; try ScaledBitmap.SetSize(TargetWidth, Round(OrigBitmap.Height * ScaleFactor)); //Return the resulting width and height for the convenience of the calling function OutputDimensions.X := ScaledBitmap.Width; OutputDimensions.Y := ScaledBitmap.Height; StretchTransfer(ScaledBitmap, Rect(0, 0, ScaledBitmap.Width, ScaledBitmap.Height), Rect(0, 0, ScaledBitmap.Width, ScaledBitmap.Height), OrigBitmap, Rect(0, 0, OrigBitmap.Width, OrigBitmap.Height), OrigBitmap.Resampler, dmOpaque, nil); {OrigBitmap.DrawMode := dmOpaque; OrigBitmap.DrawTo(ScaledBitmap, Rect(0, 0, ScaledBitmap.Width, ScaledBitmap.Height)); } BmpOut.Assign(ScaledBitmap); finally FreeAndNil(ScaledBitmap); end; end else begin BmpOut.Assign(OrigBitmap); ScaleFactor := 1; OutputDimensions.X := OrigBitmap.Width; OutputDimensions.Y := OrigBitmap.Height; end; //Save it to the right location JPGOut.CompressionQuality := 100; JPGOut.ProgressiveEncoding := True; JPGOut.Assign(BmpOut); //Enforce extension just in case JPGOut.SaveToFile(ChangeFileExt(FilePath, '.jpg')); finally FreeAndNil(OrigBitmap); end; finally FreeAndNil(BmpOut); end; finally FreeAndNil(JPGOut); end; finally Screen.Cursor := OrigCursor; end; end; end; procedure TufrmImgMarkup.aUndoExecute(Sender: TObject); begin if Screen.ActiveForm.ActiveControl is TTntEdit then (Screen.ActiveForm.ActiveControl as TTntEdit).Perform(EM_UNDO, 0, 0); if Screen.ActiveForm.ActiveControl is TTntMemo then (Screen.ActiveForm.ActiveControl as TTntMemo).Perform(EM_UNDO, 0, 0); end; procedure TufrmImgMarkup.aCutExecute(Sender: TObject); begin if Screen.ActiveForm.ActiveControl is TTntEdit then (Screen.ActiveForm.ActiveControl as TTntEdit).CutToClipboard; if Screen.ActiveForm.ActiveControl is TTntMemo then (Screen.ActiveForm.ActiveControl as TTntMemo).CutToClipboard; end; procedure TufrmImgMarkup.aCopyExecute(Sender: TObject); begin if Screen.ActiveForm.ActiveControl is TTntEdit then (Screen.ActiveForm.ActiveControl as TTntEdit).CopyToClipboard; if Screen.ActiveForm.ActiveControl is TTntMemo then (Screen.ActiveForm.ActiveControl as TTntMemo).CopyToClipboard; end; procedure TufrmImgMarkup.aPasteExecute(Sender: TObject); begin if Screen.ActiveForm.ActiveControl is TTntEdit then (Screen.ActiveForm.ActiveControl as TTntEdit).PasteFromClipboard; if Screen.ActiveForm.ActiveControl is TTntMemo then (Screen.ActiveForm.ActiveControl as TTntMemo).PasteFromClipboard; end; procedure TufrmImgMarkup.aDeleteExecute(Sender: TObject); begin if Screen.ActiveForm.ActiveControl is TTntEdit then (Screen.ActiveForm.ActiveControl as TTntEdit).SelText := ''; if Screen.ActiveForm.ActiveControl is TTntMemo then (Screen.ActiveForm.ActiveControl as TTntMemo).SelText := ''; end; procedure TufrmImgMarkup.aSelectAllExecute(Sender: TObject); begin if Screen.ActiveForm.ActiveControl is TTntEdit then (Screen.ActiveForm.ActiveControl as TTntEdit).SelectAll; if Screen.ActiveForm.ActiveControl is TTntMemo then (Screen.ActiveForm.ActiveControl as TTntMemo).SelectAll; end; procedure TufrmImgMarkup.aTutorialExecute(Sender: TObject); begin if FileExists(ExtractFilePath(Application.ExeName) + 'tutorial\getting_started.htm') then LaunchFile(ExtractFilePath(Application.ExeName) + 'tutorial\getting_started.htm'); end; procedure TufrmImgMarkup.aWebViewPrefsExecute(Sender: TObject); begin ufrmWebViewPrefs.Show; end; { TAnnotationContentFilter } procedure TufrmImgMarkup.upnImageInfoDblClick(Sender: TObject); begin { WideShowMessage(ufrmXMLUtilities.DoXSLTransformation( 'c:\temp\test\test2.xml', 'c:\temp\test\test2.xsl')); } end; procedure TufrmImgMarkup.aQuitExecute(Sender: TObject); begin Close; end; end.