//kt -- Modified with SourceScanner on 8/8/2007 unit uTemplateFields; interface uses Forms, SysUtils, StrUtils, Classes, Dialogs, StdCtrls, ExtCtrls, Controls, Contnrs, Graphics, ORClasses, ComCtrls, ORDtTm, uEvaluate; type TTemplateFieldType = (dftUnknown, dftEditBox, dftComboBox, dftButton, dftCheckBoxes, dftRadioButtons, dftDate, dftNumber, dftHyperlink, dftWP, dftText); TTmplFldDateType = (dtUnknown, dtDate, dtDateTime, dtDateReqTime, dtCombo, dtYear, dtYearMonth); const FldItemTypes = [dftComboBox, dftButton, dftCheckBoxes, dftRadioButtons, dftWP, dftText]; SepLinesTypes = [dftCheckBoxes, dftRadioButtons]; EditLenTypes = [dftEditBox, dftComboBox, dftWP]; EditDfltTypes = [dftEditBox, dftHyperlink]; EditDfltType2 = [dftEditBox, dftHyperlink, dftDate]; ItemDfltTypes = [dftComboBox, dftButton, dftCheckBoxes, dftRadioButtons]; NoRequired = [dftHyperlink, dftText]; ExcludeText = [dftHyperlink, dftText]; DateComboTypes = [dtCombo, dtYear, dtYearMonth]; type TTemplateDialogEntry = class(TObject) private FID: string; FFont: TFont; FPanel: TPanel; FControls: TStringList; FIndents: TStringList; FFirstBuild: boolean; FOnChange: TNotifyEvent; FText: string; FInternalID: string; FObj: TObject; FFieldValues: string; FUpdating: boolean; FAutoDestroyOnPanelFree: boolean; FPanelDying: boolean; FOnDestroy: TNotifyEvent; FHTMLMode : boolean; //kt added 12/28/09 FAnswerOpenTag : string; //kt added 12/28/09 FAnswerCloseTag : string; //kt added 12/28/09 procedure KillLabels; function GetFieldValues: string; procedure SetFieldValues(const Value: string); procedure SetAutoDestroyOnPanelFree(const Value: boolean); procedure SetAnswerHTMLTag(Value : string); //kt 12/28/09 protected procedure UpDownChange(Sender: TObject); procedure DoChange(Sender: TObject); function GetControlText(CtrlID: integer; NoCommas: boolean; var FoundEntry: boolean; AutoWrap: boolean; emField: string = ''): string; procedure SetControlText(CtrlID: integer; AText: string); public constructor Create(AParent: TWinControl; AID, Text: string); destructor Destroy; override; function GetPanel(MaxLen: integer; AParent: TWinControl): TPanel; function GetText: string; property Text: string read FText write FText; property InternalID: string read FInternalID write FInternalID; property ID: string read FID; property Obj: TObject read FObj write FObj; property OnChange: TNotifyEvent read FOnChange write FOnChange; property OnDestroy: TNotifyEvent read FOnDestroy write FOnDestroy; property FieldValues: string read GetFieldValues write SetFieldValues; property HTMLMode : boolean read FHTMLMode write FHTMLMode; //kt added 12/28/09 property AnswerHTMLTag : string read FAnswerOpenTag write SetAnswerHTMLTag; //kt added 12/28/09 property AutoDestroyOnPanelFree: boolean read FAutoDestroyOnPanelFree write SetAutoDestroyOnPanelFree; end; TTemplateField = class(TObject) private FMaxLen: integer; FFldName: string; FNameChanged: boolean; FLMText: string; FEditDefault: string; FNotes: string; FItems: string; FInactive: boolean; FItemDefault: string; FFldType: TTemplateFieldType; FRequired: boolean; FSepLines: boolean; FTextLen: integer; FIndent: integer; FPad: integer; FMinVal: integer; FMaxVal: integer; FIncrement: integer; FURL: string; FDateType: TTmplFldDateType; FModified: boolean; FID: string; FLocked: boolean; procedure SetEditDefault(const Value: string); procedure SetFldName(const Value: string); procedure SetFldType(const Value: TTemplateFieldType); procedure SetInactive(const Value: boolean); procedure SetRequired(const Value: boolean); procedure SetSepLines(const Value: boolean); procedure SetItemDefault(const Value: string); procedure SetItems(const Value: string); procedure SetLMText(const Value: string); procedure SetMaxLen(const Value: integer); procedure SetNotes(const Value: string); procedure SetID(const Value: string); procedure SetIncrement(const Value: integer); procedure SetIndent(const Value: integer); procedure SetMaxVal(const Value: integer); procedure SetMinVal(const Value: integer); procedure SetPad(const Value: integer); procedure SetTextLen(const Value: integer); procedure SetURL(const Value: string); function GetTemplateFieldDefault: string; procedure CreateDialogControls(Entry: TTemplateDialogEntry; var Index: Integer; CtrlID: integer); function SaveError: string; function Width: integer; function GetRequired: boolean; procedure SetDateType(const Value: TTmplFldDateType); public constructor Create(AData: TStrings); destructor Destroy; override; procedure Assign(AFld: TTemplateField); function NewField: boolean; function CanModify: boolean; property ID: string read FID write SetID; property FldName: string read FFldName write SetFldName; property NameChanged: boolean read FNameChanged; property FldType: TTemplateFieldType read FFldType write SetFldType; property MaxLen: integer read FMaxLen write SetMaxLen; property EditDefault: string read FEditDefault write SetEditDefault; property Items: string read FItems write SetItems; property ItemDefault: string read FItemDefault write SetItemDefault; property LMText: string read FLMText write SetLMText; property Inactive: boolean read FInactive write SetInactive; property Required: boolean read GetRequired write SetRequired; property SepLines: boolean read FSepLines write SetSepLines; property TextLen: integer read FTextLen write SetTextLen; property Indent: integer read FIndent write SetIndent; property Pad: integer read FPad write SetPad; property MinVal: integer read FMinVal write SetMinVal; property MaxVal: integer read FMaxVal write SetMaxVal; property Increment: integer read FIncrement write SetIncrement; property URL: string read FURL write SetURL; property DateType: TTmplFldDateType read FDateType write SetDateType; property Notes: string read FNotes write SetNotes; property TemplateFieldDefault: string read GetTemplateFieldDefault; end; TIntStruc = class(TObject) public x: integer; end; function GetDialogEntry(AParent: TWinControl; AID, AText: string): TTemplateDialogEntry; procedure FreeEntries(SL: TStrings); //kt 3/26/10 --> original procedure AssignFieldIDs(var Txt: string); overload; procedure AssignFieldIDs(var Txt: string; NameToObjID : TStringList=nil); overload; //kt 3/26/10 //kt 3/26/10 --> original procedure AssignFieldIDs(SL: TStrings); overload; procedure AssignFieldIDs(SL: TStrings; NameToObjID : TStringList=nil); overload; //kt 3/26/10 procedure HideFormulas(SL : TStrings; Formulas : TStringList); //kt added 3/26/10 procedure HideTxtObjects(SL : TStrings; TxtObjects : TStringList); //kt added 3/28/10 //function RestoreTransformFormulas(var Txt : string; Formulas, NameToObjID : TStringList) : boolean; overload; //kt added 3/26/10 function RestoreTransformFormulas(SL : TStrings; Formulas, NameToObjID : TStringList) : boolean; {overload; }//kt added 3/26/10 //kt 12/28/09 originial --> function ResolveTemplateFields(Text: string; AutoWrap: boolean; Hidden: boolean = FALSE; IncludeEmbedded: boolean = FALSE): string; function RestoreTransformTxtObjects(SL : TStrings; TxtObjects, NameToObjID : TStringList) : boolean; function ResolveTemplateFields(Text: string; AutoWrap: boolean; Hidden: boolean = FALSE; IncludeEmbedded: boolean = FALSE; HTMLMode : boolean = FALSE; //kt added 12/28/09 HTMLAnswerOpenTag : string = ''; //kt added 12/28/09 HTMLAnswerCloseTag : string = '' //kt added 12/28/09 ): string; function AreTemplateFieldsRequired(const Text: string; FldValues: TORStringList = nil): boolean; function HasTemplateField(txt: string): boolean; function GetTemplateField(ATemplateField: string; ByIEN: boolean): TTemplateField; function TemplateFieldNameProblem(Fld: TTemplateField): boolean; function SaveTemplateFieldErrors: string; procedure ClearModifiedTemplateFields; function AnyTemplateFieldsModified: boolean; procedure ListTemplateFields(const AText: string; AList: TStrings; ListErrors: boolean = FALSE); function BoilerplateTemplateFieldsOK(const AText: string; Msg: string = ''): boolean; procedure EnsureText(edt: TEdit; ud: TUpDown); procedure ConvertCodes2Text(sl: TStrings; Short: boolean); function StripEmbedded(iItems: string): string; function CloseCharPos(OpenChar, CloseChar : char; var Txt : string; StartingPos : integer=1) : integer; //kt added function FormatFormula(test: string): string; //elh 04/09/10 type TMGExtension = (tmgeFN,tmgeOBJ); TMGExtMatch = record Signature : string; SigLen : integer; EndTag : char; end; TMGExtArray = array[tmgeFN..tmgeOBJ] of TMGExtMatch; const TemplateFieldBeginSignature = '{FLD:'; TemplateFieldEndSignature = '}'; HTML_BEGIN_TAG = '{HTML:'; //kt HTML_ENDING_TAG = '}'; //kt HTML_BEGIN_TAGLEN = length(HTML_BEGIN_TAG); //kt HTML_ENDING_TAGLEN = length(HTML_ENDING_TAG); //kt FN_BEGIN_SIGNATURE = '{FN:'; //kt FN_BEGIN_TAG = '{'; //kt FN_END_TAG = '}'; //kt FN_BEGIN_SIGNATURE_LEN = length(FN_BEGIN_SIGNATURE);//kt FN_END_TAGLEN = length(FN_END_TAG); //kt FN_SHOW_TEXT = '{%_____%-#'; //kt FN_SHOW_TEXT_END = '}'; //kt FN_SHOW_TEXT_LEN = length(FN_SHOW_TEXT); //kt FN_SHOW_TEXT_END_LEN = length(FN_SHOW_TEXT_END);//kt FN_FIELD_TAG = '[FLD:'; //kt FN_FIELD_TAG_LEN = length(FN_FIELD_TAG); //kt FN_OBJ_TAG = '[OBJ:'; //kt FN_OBJ_TAG_LEN = length(FN_OBJ_TAG); //kt FLD_OBJ_SIGNATURE = '{OBJ:'; //kt FLD_OBJ_END_TAG = '}'; //kt FLD_OBJ_SIG_LEN = length(FLD_OBJ_SIGNATURE); //kt OBJ_SHOW_TEXT = '{OBJ%_____%-#'; //kt OBJ_SHOW_TEXT_END = '}'; //kt OBJ_SHOW_TEXT_LEN = length(OBJ_SHOW_TEXT); //kt TMG_MATCH : TMGExtArray = ( (Signature : FN_BEGIN_SIGNATURE; SigLen : FN_BEGIN_SIGNATURE_LEN; EndTag : FN_END_TAG), (Signature : FLD_OBJ_SIGNATURE; SigLen : FLD_OBJ_SIG_LEN; EndTag : FLD_OBJ_END_TAG) ); //MissingFieldsTxt = 'One or more required fields must still be entered.'; <-- original line. //kt 8/8/2007 function MissingFieldsTxt : string; //kt added Const TemplateFieldTypeCodes: array[TTemplateFieldType] of string[1] = { dftUnknown } ('', { dftEditBox } 'E', { dftComboBox } 'C', { dftButton } 'B', { dftCheckBoxes } 'X', { dftRadioButtons } 'R', { dftDate } 'D', { dftNumber } 'N', { dftHyperlink } 'H', { dftWP } 'W', { dftText } 'T'); function TemplateFieldTypeDesc(index: TTemplateFieldType; short : boolean) : string; (* //kt replaced with function below TemplateFieldTypeDesc: array[TTemplateFieldType, boolean] of string = { dftUnknown } (('',''), { dftEditBox } ('Edit Box', 'Edit'), { dftComboBox } ('Combo Box', 'Combo'), { dftButton } ('Button', 'Button'), { dftCheckBoxes } ('Check Boxes', 'Check'), { dftRadioButtons } ('Radio Buttons', 'Radio'), { dftDate } ('Date', 'Date'), { dftNumber } ('Number', 'Num'), { dftHyperlink } ('Hyperlink', 'Link'), { dftWP } ('Word Processing','WP'), { dftWP } ('Display Text', 'Text')); *) function TemplateDateTypeDesc(index: TTmplFldDateType; Short : boolean) : string; (* //kt replaced with function below TemplateDateTypeDesc: array[TTmplFldDateType, boolean] of string = { dtUnknown } (('',''), // { dtDate } ('Date', 'Date'), <-- original line. //kt 8/8/2007 // { dtDateTime } ('Date & Time', 'Time'), <-- original line. //kt 8/8/2007 // { dtDateReqTime } ('Date & Req Time','R.Time'), <-- original line. //kt 8/8/2007 // { dtCombo } ('Date Combo', 'C.Date'), <-- original line. //kt 8/8/2007 // { dtYear } ('Year', 'Year'), <-- original line. //kt 8/8/2007 // { dtYearMonth } ('Year & Month', 'Month')); <-- original line. //kt 8/8/2007 *) Const FldNames: array[TTemplateFieldType] of string = { dftUnknown } ('', { dftEditBox } 'EDIT', { dftComboBox } 'LIST', { dftButton } 'BTTN', { dftCheckBoxes } 'CBOX', { dftRadioButtons } 'RBTN', { dftDate } 'DATE', { dftNumber } 'NUMB', { dftHyperlink } 'LINK', { dftWP } 'WRDP', { dftTExt } 'TEXT'); TemplateFieldDateCodes: array[TTmplFldDateType] of string[1] = { dtUnknown } ('', { dtDate } 'D', { dtDateTime } 'T', { dtDateReqTime } 'R', { dtCombo } 'C', { dtYear } 'Y', { dtYearMonth } 'M'); MaxTFWPLines = 20; MaxTFEdtLen = 70; type TFieldPanel = class(TPanel) {This is the panel associated with the child} private {dialog checkboxes in reminders dialogs} FOnDestroy: TNotifyEvent; FCanvas: TControlCanvas; {used to draw focus rect} function GetFocus: boolean; procedure SetTheFocus(const Value: boolean); protected {used to draw focus rect} procedure Paint; override; {used to draw focus rect} public destructor Destroy; override; property OnDestroy: TNotifyEvent read FOnDestroy write FOnDestroy; property Focus: boolean read GetFocus write SetTheFocus; {to draw focus rect} property OnKeyPress; {to click the checkbox when spacebar is pressed} end; implementation uses ORFn, rTemplates, ORCtrls, mTemplateFieldButton, dShared, uConst, uCore, rCore, Windows, ORNet, //kt TRPCB, //kt DKLang; //kt const NewTemplateField = 'NEW TEMPLATE FIELD'; TemplateFieldSignatureLen = length(TemplateFieldBeginSignature); TemplateFieldSignatureEndLen = length(TemplateFieldEndSignature); var uTmplFlds: TList = nil; uEntries: TStringList = nil; uNewTemplateFieldIDCnt: longint = 0; uRadioGroupIndex: integer = 0; uInternalFieldIDCount: integer = 0; uInternalFormulaCount: integer = 0; //kt uInternalTxtObjCount : integer = 0; //kt const FieldIDDelim = '`'; FieldIDLen = 6; NewLine = 'NL'; type TFieldLabel = class(TLabel) private FExclude: boolean; public property Exclude: boolean read FExclude; end; TWebLabel = class(TFieldLabel) private FAddr: string; procedure Clicked(Sender: TObject); public procedure Init(Addr: string); end; function MissingFieldsTxt : string; begin Result := DKLangConstW('uTemplateFields_One_or_more_required_fields_must_still_be_enteredx'); end; //kt 8-17-07 Added to replace constant with function function TemplateFieldTypeDesc(index: TTemplateFieldType; Short : boolean) : string; begin Result := ''; case index of dftUnknown : Result := ''; dftEditBox : if not Short then Result := DKLangConstW('uTemplateFields_Edit_Box') else Result := DKLangConstW('uTemplateFields_Edit'); dftComboBox : if not Short then Result := DKLangConstW('uTemplateFields_Combo_Box') else Result := DKLangConstW('uTemplateFields_Combo'); dftButton : if not Short then Result := DKLangConstW('uTemplateFields_Button') else Result := DKLangConstW('uTemplateFields_Button'); dftCheckBoxes : if not Short then Result := DKLangConstW('uTemplateFields_Check_Boxes') else Result := DKLangConstW('uTemplateFields_Check'); dftRadioButtons : if not Short then Result := DKLangConstW('uTemplateFields_Radio_Buttons') else Result := DKLangConstW('uTemplateFields_Radio'); dftDate : if not Short then Result := DKLangConstW('uTemplateFields_Date') else Result := DKLangConstW('uTemplateFields_Date'); dftNumber : if not Short then Result := DKLangConstW('uTemplateFields_Number') else Result := DKLangConstW('uTemplateFields_Num'); dftHyperlink : if not Short then Result := DKLangConstW('uTemplateFields_Hyperlink') else Result := DKLangConstW('uTemplateFields_Link'); dftWP : if not Short then Result := DKLangConstW('uTemplateFields_Word_Processing') else Result := DKLangConstW('uTemplateFields_WP'); dftText : if not Short then Result := DKLangConstW('uTemplateFields_Display_Text') else Result := DKLangConstW('uTemplateFields_Text'); end; {case} end; //kt 8-17-07 Added to replace constant with function function TemplateDateTypeDesc(index: TTmplFldDateType; Short : boolean) : string; begin Result := ''; case index of dtUnknown : Result := ''; dtDate : if not Short then Result := DKLangConstW('uTemplateFields_Date') else Result := DKLangConstW('uTemplateFields_Date'); dtDateTime : if not Short then Result := DKLangConstW('uTemplateFields_Date_x_Time') else Result := DKLangConstW('uTemplateFields_Time'); dtDateReqTime : if not Short then Result := DKLangConstW('uTemplateFields_Date_x_Req_Time') else Result := DKLangConstW('uTemplateFields_RxTime'); dtCombo : if not Short then Result := DKLangConstW('uTemplateFields_Date_Combo') else Result := DKLangConstW('uTemplateFields_CxDate'); dtYear : if not Short then Result := DKLangConstW('uTemplateFields_Year') else Result := DKLangConstW('uTemplateFields_Year'); dtYearMonth : if not Short then Result := DKLangConstW('uTemplateFields_Year_x_Month') else Result := DKLangConstW('uTemplateFields_Month'); end; {case} end; function GetNewFieldID: string; begin inc(uInternalFieldIDCount); Result := IntToStr(uInternalFieldIDCount); Result := FieldIDDelim + copy(StringOfChar('0', FieldIDLen-2) + Result, length(Result), FieldIDLen-1); end; function GetDialogEntry(AParent: TWinControl; AID, AText: string): TTemplateDialogEntry; var idx: integer; begin Result := nil; if AID = '' then exit; if(not assigned(uEntries)) then uEntries := TStringList.Create; idx := uEntries.IndexOf(AID); if(idx < 0) then begin Result := TTemplateDialogEntry.Create(AParent, AID, AText); uEntries.AddObject(AID, Result); end else Result := TTemplateDialogEntry(uEntries.Objects[idx]); end; procedure FreeEntries(SL: TStrings); var i, idx, cnt: integer; begin if(assigned(uEntries)) then begin for i := SL.Count-1 downto 0 do begin idx := uEntries.IndexOf(SL[i]); if(idx >= 0) then begin cnt := uEntries.Count; if(assigned(uEntries.Objects[idx])) then begin TTemplateDialogEntry(uEntries.Objects[idx]).AutoDestroyOnPanelFree := FALSE; uEntries.Objects[idx].Free; end; if cnt = uEntries.Count then uEntries.Delete(idx); end; end; if(uEntries.Count = 0) then uInternalFieldIDCount := 0; uInternalFormulaCount := 0; //kt uInternalTxtObjCount := 0; //kt end; end; //kt original line --> procedure AssignFieldIDs(var Txt: string); procedure AssignFieldIDs(var Txt: string; NameToObjID : TStringList); //kt var i: integer; p2 : integer; //kt FldName : string; //kt FldID : string; //kt begin i := 0; while (i < length(Txt)) do begin inc(i); if copy(Txt,i,TemplateFieldSignatureLen) = TemplateFieldBeginSignature then begin inc(i,TemplateFieldSignatureLen); if(i < length(Txt)) and (copy(Txt,i,1) <> FieldIDDelim) then begin p2 := PosEx(TemplateFieldEndSignature,Txt,i); //kt FldName := ''; //kt if p2 > 0 then FldName := Trim(copy(Txt,i,(p2-i))); //kt insert(GetNewFieldID, Txt, i); inc(i, FieldIDLen); if (FldName <> '') and Assigned(NameToObjID) then begin //kt NameToObjID.AddObject(FldName,Pointer(uInternalFieldIDCount)); //kt end; //kt end; end; end; end; procedure AssignFieldIDs(SL: TStrings; NameToObjID : TStringList); var i: integer; txt: string; begin for i := 0 to SL.Count-1 do begin txt := SL[i]; //kt AssignFieldIDs(txt); AssignFieldIDs(txt, NameToObjID); //kt SL[i] := txt; end; end; function CloseCharPos(OpenChar, CloseChar : char; var Txt : string; StartingPos : integer=1) : integer; //kt added function //Return the position of a closing character, ignoring all intervening nested open and close chars //NOTE: It is expected that StartingPos is pointing to the first opening character. var i : integer; CloseMatchesNeeded : integer; begin Result := 0; CloseMatchesNeeded := 1; for i := StartingPos to Length(Txt) do begin if (Txt[i] = OpenChar) and (i <> StartingPos) then Inc(CloseMatchesNeeded); if Txt[i] = CloseChar then Dec(CloseMatchesNeeded); if CloseMatchesNeeded = 0 then begin Result := i; break; end; end; end; procedure HideFormulas(SL : TStrings; Formulas : TStringList); //kt added function //NOTE: formulas will not be allowed to use the '}' character var p1,p2 : integer; FnStr : string; SubStrA,SubStrB : string; Txt : String; begin Txt := SL.Text; p1 := Pos(FN_BEGIN_SIGNATURE,Txt); while (p1>0) do begin SubStrA := MidStr(Txt,1,p1-1); p1 := p1 + FN_BEGIN_SIGNATURE_LEN; //p2 := PosEx(FN_END_TAG,Txt,p1); p2 := CloseCharPos(FN_BEGIN_TAG, FN_END_TAG, Txt, p1); SubStrB := MidStr(Txt,p2+1,StrLen(PChar(Txt))+1); //Changed from 999 to StrLen(PChar(Txt))+1. Some characters were getting lost including the dialog tags that trigger the dialog box elh 04/08/10 FnStr := MidStr(Txt,p1, (p2-p1)); FnStr := AnsiReplaceText(FnStr,#9,''); FnStr := AnsiReplaceText(FnStr,#10,''); FnStr := AnsiReplaceText(FnStr,#13,''); //FnStr := AnsiReplaceText(FnStr,' ',''); inc(uInternalFormulaCount); Formulas.AddObject(FnStr,Pointer(uInternalFormulaCount)); Txt := SubStrA + FN_SHOW_TEXT + IntToStr(uInternalFormulaCount) + FN_SHOW_TEXT_END + SubStrB; p1 := PosEx(FN_BEGIN_SIGNATURE,Txt,p1); end; SL.Text := Txt; end; procedure HideTxtObjects(SL : TStrings; TxtObjects : TStringList); //kt added 3/28/10 //kt added function var p1,p2 : integer; FnStr : string; SubStrA,SubStrB : string; Txt : String; begin Txt := SL.Text; p1 := Pos(FLD_OBJ_SIGNATURE,Txt); while (p1>0) do begin SubStrA := MidStr(Txt,1,p1-1); p1 := p1 + FN_OBJ_TAG_LEN; p2 := CloseCharPos(FN_BEGIN_TAG, FN_END_TAG, Txt, p1); SubStrB := MidStr(Txt,p2+1,StrLen(PChar(Txt))+1); //Changed from 999 to StrLen(PChar(Txt))+1. Some characters were getting lost including the dialog tags that trigger the dialog box elh 04/13/10 FnStr := MidStr(Txt,p1, (p2-p1)); FnStr := AnsiReplaceText(FnStr,#9,''); FnStr := AnsiReplaceText(FnStr,#10,''); FnStr := AnsiReplaceText(FnStr,#13,''); inc(uInternalTxtObjCount); TxtObjects.AddObject(FnStr,Pointer(uInternalTxtObjCount)); Txt := SubStrA + OBJ_SHOW_TEXT + IntToStr(uInternalTxtObjCount) + OBJ_SHOW_TEXT_END + SubStrB; p1 := PosEx(FLD_OBJ_SIGNATURE,Txt,p1); end; SL.Text := Txt; end; function InsideMarkers(var S : string; MarkerCh : char; P : integer) : boolean; //Function returns if position P is inside characters MarkerCh. //e.g. S = 'xxx|xxxxx|xxxxx' MarkerCh='|' // P = 2 ==> result is false // P = 5 ==> result is true // P = 12 ==> result is false var p1,p2 : integer; Inside : boolean; begin Inside := false; p1 := Pos(MarkerCh,S); while (p1 > 0) do begin if (p1 >= P) then break; p1 := PosEx(MarkerCh,S,p1+1); if (p1 > 0) and (p1 > P) then Inside := not Inside; end; Result := Inside; end; function SubstuteIDs(Txt : string; NameToObjID : TStringList) : string; //kt added function //Prefix any field names with their FldID's, in format of FieldIDDelim+FldID // E.g. [FLD:1:NUM1-16] --> `00001NUM1-16` //Note: Field ID's are started with character FieldIDDelim, and are of a fixed length (FieldIDLen) (* Syntax examples: {FN:[FLD:1:NUMB1-16]-[FLD:2:NUMB1-16]-[FLD:3:NUMB1-16]}, or {FN:[OBJ:TABLE1]-[FLD:2:NUMB1-16]-[FLD:3:NUMB1-16]}, or {FN:[OBJ:TABLE2("POTASSIUM")]-[FLD:2:NUMB1-16]-[FLD:3:NUMB1-16]}, or {FN:[OBJ:TABLE2([FLD:1:NUMB1-16])]-[FLD:2:NUMB1-16]-[FLD:3:NUMB1-16]} {FN:[OBJ:TABLE2((5+3)/2)]-[FLD:2:NUMB1-16]-[FLD:3:NUMB1-16]} (arbitrary deep nesting) Note: arguments should be round by matching [ ]'s An argument will start with a TYPE (so far, FLD or OBJ) and ':' If TYPE is FLD, there will be :number:, with number being same as number in old format (i.e. ...]#2). If number not provided, then default value is 1 If TYPE is OBJ, then this indicates that the parameter name (e.g. TABLE) is the name of a TIU TEXT object, that will be processed on the server. Parameters should be resolved before passing to the server. *) var i,j,p1,p2 : integer; SubStrA,SubStrB, NumStr : string; FldIDNum,CountofSimilar : integer; FldIDNumStr : string; CountOfSimStr : string; Temp,FldName : string; Skip : boolean; begin for i := 0 to NameToObjID.Count-1 do begin CountofSimilar := 0; FldName := NameToObjID.Strings[i]; for j := 0 to i do begin if NameToObjID.Strings[j] = FldName then inc(CountofSimilar); //Changed from i to j elh 04/08/10 end; CountOfSimStr := IntToStr(CountofSimilar); FldIDNum := Integer(NameToObjID.Objects[i]); FldIDNumStr := IntToStr(FldIDNum); FldIDNumStr := FieldIDDelim + StringOfChar('0', FieldIDLen-1-Length(FldIDNumStr)) + FldIDNumStr; p1 := 1; p1 := PosEx(FldName,Txt,p1); while InsideMarkers(Txt, FieldIDDelim, p1) do begin //Ignore included fieldnames from prior cycle. p2 := PosEx(FieldIDDelim,Txt,p1+1); if p2 >0 then begin p1 := p2+1; p1 := PosEx(FldName,Txt,p1); end else p1 := 999; //error condition. end; while (p1>0) and (p1 < 999) do begin Skip := false; SubStrA := MidStr(Txt,1,p1-1); SubStrB := MidStr(Txt, p1+Length(FldName), 999); if (LeftStr(SubStrB,1)=']') and (Pos(FN_FIELD_TAG,SubStrA) > 0) then begin NumStr := piece(RightStr(SubStrA,7),':',2); SubStrA := LeftStr(SubStrA,Length(SubStrA)-7); p2 := 2; SubStrB := MidStr(SubStrB,p2,999); if NumStr <> CountOfSimStr then begin Skip := true; Inc(p1); end; end else begin Skip := true; Inc(p1); end; if not Skip then begin Txt := SubStrA + FldIDNumStr +FldName + FieldIDDelim; p1 := Length(Txt); Txt := Txt + SubStrB; end; p1 := PosEx(FldName,Txt,p1); end; end; Result := Txt; end; function RestoreTransformFormulas(SL : TStrings; Formulas, NameToObjID : TStringList) : boolean; //kt added 3/26/10 //Returns if any changes made //Replace formula text back in, and change field names into FldID's function GetFormula(NumStr : string) : string; //Return formula text based on provided index number of formula var num, i : integer; PtrNum : Pointer; begin Result := ''; try Num := StrToInt(NumStr); PtrNum := Pointer(Num); for i := 0 to Formulas.Count-1 do begin if Formulas.Objects[i] = PtrNum then begin Result := Formulas.Strings[i]; break; end; end; except on EConvertError do Result := '??'; end; end; var p1,p2 : integer; count : integer; FnStr : string; Txt : string; SubStrA,SubStrB : string; begin Txt := SL.Text; Result := false; p1 := Pos(FN_SHOW_TEXT,Txt); while (p1>0) do begin SubStrA := MidStr(Txt,1,p1-1); p1 := p1 + FN_SHOW_TEXT_LEN; p2 := PosEx(FN_SHOW_TEXT_END,Txt,p1); SubStrB := MidStr(Txt,p2+1,StrLen(PChar(Txt))+1); //Changed from 999 to StrLen(PChar(Txt))+1. Some characters were getting lost including the dialog tags that trigger the dialog box elh 04/13/10 FnStr := MidStr(Txt,p1, (p2-p1)); FnStr := GetFormula(FnStr); FnStr := SubstuteIDs(FnStr,NameToObjID); Txt := SubStrA + FN_BEGIN_SIGNATURE + FnStr + FN_END_TAG + SubStrB; Result := true; p1 := PosEx(FN_SHOW_TEXT,Txt,p1); end; SL.Text := Txt; end; { function RestoreTransformFormulas(SL : TStrings; Formulas, NameToObjID : TStringList) : boolean; overload; //kt added 3/26/10 //Returns if any changes made var i: integer; Changed : boolean; txt: string; begin Result := false; for i := 0 to SL.Count-1 do begin txt := SL[i]; Changed := RestoreTransformFormulas(txt, Formulas, NameToObjID); Result := Result or Changed; SL[i] := txt; end; end; } function RestoreTransformTxtObjects(SL : TStrings; TxtObjects, NameToObjID : TStringList) : boolean; //kt added 3/28/10 //Returns if any changes made //Replace formula text back in, and change field names into FldID's function GetTxtObjects(NumStr : string) : string; //Return TxtObject text based on provided index number of formula var num, i : integer; PtrNum : Pointer; begin Result := ''; try Num := StrToInt(NumStr); PtrNum := Pointer(Num); for i := 0 to TxtObjects.Count-1 do begin if TxtObjects.Objects[i] = PtrNum then begin Result := TxtObjects.Strings[i]; break; end; end; except on EConvertError do Result := '??'; end; end; var p1,p2 : integer; count : integer; ObjStr : string; SubStrA,SubStrB : string; Txt : string; begin Txt := SL.Text; Result := false; p1 := Pos(OBJ_SHOW_TEXT,Txt); while (p1>0) do begin SubStrA := MidStr(Txt,1,p1-1); p1 := p1 + OBJ_SHOW_TEXT_LEN; p2 := PosEx(OBJ_SHOW_TEXT_END,Txt,p1); SubStrB := MidStr(Txt,p2+1,StrLen(PChar(Txt))+1); //Changed from 999 to StrLen(PChar(Txt))+1. Some characters were getting lost including the dialog tags that trigger the dialog box elh 04/13/10 ObjStr := MidStr(Txt,p1, (p2-p1)); ObjStr := GetTxtObjects(ObjStr); ObjStr := SubstuteIDs(ObjStr,NameToObjID); Txt := SubStrA + FLD_OBJ_SIGNATURE + ObjStr + FLD_OBJ_END_TAG + SubStrB; Result := true; p1 := PosEx(OBJ_SHOW_TEXT,Txt,p1); end; SL.Text := Txt; end; function GetRPCTIUObj(TIUObjName : string) : string; //kt added entire function 3/28/10 //Based on rTemplates.GetTemplateText(BoilerPlate: TStrings); begin TIUObjName := AnsiReplaceText(TIUObjName,'|',''); with RPCBrokerV do begin ClearParameters := True; RemoteProcedure := 'TIU TEMPLATE GETTEXT'; Param[0].PType := literal; Param[0].Value := Patient.DFN; Param[1].PType := literal; Param[1].Value := Encounter.VisitStr; Param[2].PType := list; Param[2].Mult[IntToStr(1)+',0'] := '|' + TIUObjName + '|'; CallBroker; RPCBrokerV.Results.Delete(0); if RPCBrokerV.Results.count > 0 then begin Result := RPCBrokerV.Results.Strings[0]; end else Result := ''; RPCBrokerV.Results.Clear; end; end; Procedure EvalTIUObjects(var Formula : string); //kt added entire function 3/28/10 var p1,p2 : integer; OP1,OP2 : integer; Problem : boolean; SubStrA, SubStrB : string; TIUObj,Argument,s : string; begin p1 := Pos(FN_OBJ_TAG, Formula); while (p1 > 0) do begin p2 := CloseCharPos('[',']',Formula, p1+1); if p2=0 then begin Formula := 'ERROR. Matching "]" not found after ' + FN_OBJ_TAG + '.'; Exit; end; SubStrA := MidStr(Formula,1,p1-1); p1 := p1+FN_OBJ_TAG_LEN; TIUObj := Trim(MidStr(Formula, p1, (p2-p1))); SubStrB := MidStr(Formula,p2+1,999); OP1 := Pos('{',TIUObj); if (OP1 > 0) then begin OP2 := CloseCharPos('{','}', TIUObj, OP1+1); if OP2=0 then begin Formula := 'ERROR. Matching ")" not found after "(".'; Exit; end; Argument := MidStr(TIUObj,OP1+1,(OP2-(OP1+1))); if Pos(FN_OBJ_TAG,Argument)>0 then begin EvalTIUObjects(Argument) end; Problem := false; s := FloatToStr(StringEval(Argument,Problem)); if Problem then begin Formula := 'ERROR evaluating argument: [' + s + '].'; Exit; end else begin Argument := s; end; TIUObj := MidStr(TIUObj,1,OP1-1) + '{' + Argument + '}'; end; TIUObj := GetRPCTIUObj(TIUObj); Formula := SubStrA + TIUObj + SubStrB; p1 := Pos(FN_OBJ_TAG, Formula); end; end; procedure WordWrapText(var Txt: string; HTMLMode : boolean); var TmpSL: TStringList; i: integer; function WrappedText(const Str: string; boolHTMLMode : boolean): string; var i, i2, j, k, m: integer; HTMLStrLen : integer; Temp, Temp1, Temp2: string; begin Temp := Str; Result := ''; i2 := 0; repeat i := pos(TemplateFieldBeginSignature, Temp); if i>0 then j := pos(TemplateFieldEndSignature, copy(Temp, i, MaxInt)) else j := 0; if (j > 0) then begin i2 := pos(TemplateFieldBeginSignature, copy(Temp, i+TemplateFieldSignatureLen, MaxInt)); if (i2 = 0) then i2 := MaxInt else i2 := i + TemplateFieldSignatureLen + i2 - 1; end; if (i>0) and (j=0) then i := 0; if (i>0) and (j>0) then if (j > i2) then begin Result := Result + copy(Temp, 1, i2-1); delete(Temp, 1, i2-1); end else begin for k := (i+TemplateFieldSignatureLen) to (i+j-2) do if Temp[k]=' ' then Temp[k]:= #1; i := i + j - 1; Result := Result + copy(Temp,1,i); delete(Temp,1,i); end; until (i = 0); Result := Result + Temp; //Count the HTML tag length and add to MAX_ENTRY WIDTH elh 1-29-10 HTMLStrLen := 0; if boolHTMLMode = True then begin temp1 := Result; while (pos('<',temp1)>0) and (pos('>',temp1)>0) do begin temp2 := MidStr(temp1,pos('<',temp1),pos('>',temp1)-pos('<',temp1)+1); HTMLStrLen := HTMLStrLen + strlen(PChar(temp2)); temp1 := Rightstr(temp1,strlen(PChar(temp1))-pos('>',temp1)); end; end; Result := WrapText(Result, #13#10, [' '], MAX_ENTRY_WIDTH+HTMLStrLen); //added +HTMLStrLen elh 1-29-10 repeat i := pos(#1, Result); if i > 0 then Result[i] := ' '; until i = 0; end; begin if length(Txt) > MAX_ENTRY_WIDTH then begin TmpSL := TStringList.Create; try TmpSL.Text := Txt; Txt := ''; for i := 0 to TmpSL.Count-1 do begin if Txt <> '' then Txt := Txt + CRLF; Txt := Txt + WrappedText(TmpSL[i],HTMLMode); end; finally TmpSL.Free; end; end; end; function ResolveTemplateFields(Text: string; AutoWrap: boolean; Hidden: boolean = FALSE; IncludeEmbedded: boolean = FALSE; HTMLMode : boolean = FALSE; //kt added 12/28/09 HTMLAnswerOpenTag : string = ''; //kt added 12/28/09 HTMLAnswerCloseTag : string = '' //kt added 12/28/09 ): string; var flen, CtrlID, i, j: integer; Entry: TTemplateDialogEntry; iField, Temp, NewTxt, Fld: string; FoundEntry,Problem: boolean; TmplFld: TTemplateField; tempSL : TStringList; SubStrA, SubStrB : string; //kt ExtMode : TMGExtension; //kt TempStr, FnObjStr,Argument : string; //kt FnP1,FnP2,p1,p2 : integer; //kt procedure AddNewTxt; begin if(NewTxt <> '') then begin insert(StringOfChar('x',length(NewTxt)), Temp, i); insert(NewTxt, Result, i); inc(i, length(NewTxt)); end; end; begin if(not assigned(uEntries)) then uEntries := TStringList.Create; Result := Text; Temp := Text; // Use Temp to allow template fields to contain other template field references repeat i := pos(TemplateFieldBeginSignature, Temp); if(i > 0) then begin CtrlID := 0; if(copy(Temp, i + TemplateFieldSignatureLen, 1) = FieldIDDelim) then begin CtrlID := StrToIntDef(copy(Temp, i + TemplateFieldSignatureLen + 1, FieldIDLen-1), 0); delete(Temp,i + TemplateFieldSignatureLen, FieldIDLen); delete(Result,i + TemplateFieldSignatureLen, FieldIDLen); end; j := pos(TemplateFieldEndSignature, copy(Temp, i + TemplateFieldSignatureLen, MaxInt)); Fld := ''; if(j > 0) then begin inc(j, i + TemplateFieldSignatureLen - 1); flen := j - i - TemplateFieldSignatureLen; Fld := copy(Temp,i + TemplateFieldSignatureLen, flen); delete(Temp,i,flen + TemplateFieldSignatureLen + 1); delete(Result,i,flen + TemplateFieldSignatureLen + 1); end else begin delete(Temp,i,TemplateFieldSignatureLen); delete(Result,i,TemplateFieldSignatureLen); end; if(CtrlID > 0) then begin FoundEntry := FALSE; for j := 0 to uEntries.Count-1 do begin Entry := TTemplateDialogEntry(uEntries.Objects[j]); if(assigned(Entry)) then begin if IncludeEmbedded then iField := Fld else iField := ''; NewTxt := Entry.GetControlText(CtrlID, FALSE, FoundEntry, AutoWrap, iField); TmplFld := GetTemplateField(Fld, FALSE); if (assigned(TmplFld)) and (TmplFld.DateType in DateComboTypes) then {if this is a TORDateBox} NewTxt := Piece(NewTxt,':',1); {we only want the first piece of NewTxt} //kt 12/28/09 --- Start mod to wrap answers in custom HTML tag --- if (HTMLMode=true) and (NewTxt <> '') then begin NewTxt := HTMLAnswerOpenTag + NewTxt + HTMLAnswerCloseTag; //kt 12/29/09 end; //kt --- End mod to wrap answers in custom HTML tag --- AddNewTxt; end; if FoundEntry then break; end; if Hidden and (not FoundEntry) and (Fld <> '') then begin NewTxt := TemplateFieldBeginSignature + Fld + TemplateFieldEndSignature; AddNewTxt; end; end; end else begin if HTMLMode=true then begin tempSL := TStringList.create; tempSL.Text := Result; if tempSL.Count < 3 then begin Result := HTMLAnswerOpenTag + Result + HTMLAnswerCloseTag; end; tempSL.Free; end; end; until(i = 0); //kt -- begin mod --- Entire section added. Temp := Result; for ExtMode := tmgeFN to tmgeOBJ do begin repeat i := pos(TMG_MATCH[ExtMode].Signature, Temp); if(i > 0) then begin FnP1 := i; FnP2 := CloseCharPos('{', TMG_MATCH[ExtMode].EndTag, Temp, i); //FnP2 := Pos(TMG_MATCH[ExtMode].EndTag,Temp); //Should use CloseCharPos function p1 := FnP1 + TMG_MATCH[ExtMode].SigLen; FnObjStr := MidStr(Temp, p1, FnP2-p1); p1 := Pos(FieldIDDelim,FnObjStr); while (p1 > 0) do begin SubStrA := MidStr(FnObjStr,1,p1-1); p2 := PosEx(FieldIDDelim,FnObjStr,p1+1); Argument := MidStr(FnObjStr,p1+1,(p2-p1)-1); SubStrB := MidStr(FnObjStr,p2+1,StrLen(PChar(FnObjStr))+1); CtrlID := StrToIntDef(MidStr(Argument,1,FieldIDLen-1), 0); Fld := MidStr(Argument,FieldIDLen,StrLen(PChar(Argument))+1); if(CtrlID > 0) then begin FoundEntry := FALSE; for j := 0 to uEntries.Count-1 do begin Entry := TTemplateDialogEntry(uEntries.Objects[j]); if(assigned(Entry)) then begin if IncludeEmbedded then iField := Fld else iField := ''; NewTxt := Entry.GetControlText(CtrlID, FALSE, FoundEntry, AutoWrap, iField); TmplFld := GetTemplateField(Fld, FALSE); if (assigned(TmplFld)) and (TmplFld.DateType in DateComboTypes) then {if this is a TORDateBox} NewTxt := Piece(NewTxt,':',1); {we only want the first piece of NewTxt} Argument := Trim(NewTxt); end; end; end else Argument := '??'; FnObjStr := SubStrA + Argument + SubStrB; p1 := Pos(FieldIDDelim,FnObjStr); end; if (ExtMode = tmgeOBJ) then begin FnObjStr := FN_OBJ_TAG + FnObjStr + ']'; end; FnObjStr := FormatFormula(FnObjStr); //Added to remove all characters from the formula elh 4/9/10 if (Pos(FN_OBJ_TAG,FnObjStr)>0) then begin EvalTIUObjects(FnObjStr); end; if ExtMode = tmgeFN then begin Problem := false; TempStr := AnsiReplaceText(FnObjStr,' ',''); TempStr := FloatToStr(StringEval(TempStr,Problem)); if not Problem then FnObjStr := TempStr; end; SubStrA := MidStr(Temp,1,FnP1-1); SubStrB := MidStr(Temp,FnP2+1,StrLen(PChar(Temp))+1); if (HTMLMode=true) and (FnObjStr <> '') then begin FnObjStr := HTMLAnswerOpenTag + FnObjStr + HTMLAnswerCloseTag; end; Temp := SubStrA + FnObjStr + SubStrB; end else begin if HTMLMode=true then begin tempSL := TStringList.create; tempSL.Text := Result; if tempSL.Count < 3 then begin Result := HTMLAnswerOpenTag + Result + HTMLAnswerCloseTag; end; tempSL.Free; end; end; until(i = 0); end; Result := Temp; //kt -- end mod -- if not AutoWrap then WordWrapText(Result,HTMLMode); end; function AreTemplateFieldsRequired(const Text: string; FldValues: TORStringList = nil): boolean; var flen, CtrlID, i, j: integer; Entry: TTemplateDialogEntry; Fld: TTemplateField; Temp, NewTxt, FldName: string; FoundEntry: boolean; SubStrA,SubStrB : string; begin if(not assigned(uEntries)) then uEntries := TStringList.Create; Temp := Text; Result := FALSE; repeat i := pos(TemplateFieldBeginSignature, Temp); if(i > 0) then begin CtrlID := 0; if(copy(Temp, i + TemplateFieldSignatureLen, 1) = FieldIDDelim) then begin CtrlID := StrToIntDef(copy(Temp, i + TemplateFieldSignatureLen + 1, FieldIDLen-1), 0); delete(Temp,i + TemplateFieldSignatureLen, FieldIDLen); end; j := pos(TemplateFieldEndSignature, copy(Temp, i + TemplateFieldSignatureLen, MaxInt)); if(j > 0) then begin inc(j, i + TemplateFieldSignatureLen - 1); flen := j - i - TemplateFieldSignatureLen; FldName := copy(Temp, i + TemplateFieldSignatureLen, flen); Fld := GetTemplateField(FldName, FALSE); delete(Temp,i,flen + TemplateFieldSignatureLen + 1); end else begin delete(Temp,i,TemplateFieldSignatureLen); Fld := nil; end; if(CtrlID > 0) and (assigned(Fld)) and (Fld.Required) then begin FoundEntry := FALSE; for j := 0 to uEntries.Count-1 do begin Entry := TTemplateDialogEntry(uEntries.Objects[j]); if(assigned(Entry)) then begin NewTxt := Entry.GetControlText(CtrlID, TRUE, FoundEntry, FALSE); if FoundEntry and (NewTxt = '') then Result := TRUE; end; if FoundEntry then break; end; if (not FoundEntry) and assigned(FldValues) then begin j := FldValues.IndexOfPiece(IntToStr(CtrlID)); if(j < 0) or (Piece(FldValues[j],U,2) = '') then Result := TRUE; end; end; end; until((i = 0) or Result); end; function HasTemplateField(txt: string): boolean; begin Result := (pos(TemplateFieldBeginSignature, txt) > 0); end; function GetTemplateField(ATemplateField: string; ByIEN: boolean): TTemplateField; var i, idx: integer; AData: TStrings; begin Result := nil; if(not assigned(uTmplFlds)) then uTmplFlds := TList.Create; idx := -1; for i := 0 to uTmplFlds.Count-1 do begin if(ByIEN) then begin if(TTemplateField(uTmplFlds[i]).FID = ATemplateField) then begin idx := i; break; end; end else begin if(TTemplateField(uTmplFlds[i]).FFldName = ATemplateField) then begin idx := i; break; end; end; end; if(idx < 0) then begin if(ByIEN) then AData := LoadTemplateFieldByIEN(ATemplateField) else AData := LoadTemplateField(ATemplateField); if(AData.Count > 1) then Result := TTemplateField.Create(AData); end else Result := TTemplateField(uTmplFlds[idx]); end; function TemplateFieldNameProblem(Fld: TTemplateField): boolean; //const //DUPFLD = 'Field Name is not unique'; <-- original line. //kt 8/8/2007 var i: integer; msg: string; DUPFLD : string; //kt begin DUPFLD := DKLangConstW('uTemplateFields_Field_Name_is_not_unique'); //kt added 8/8/2007 msg := ''; if(Fld.FldName = NewTemplateField) then // msg := 'Field Name can not be ' + NewTemplateField <-- original line. //kt 8/8/2007 msg := DKLangConstW('uTemplateFields_Field_Name_can_not_be') + NewTemplateField //kt added 8/8/2007 else if(length(Fld.FldName) < 3) then // msg := 'Field Name must be at least three characters in length' <-- original line. //kt 8/8/2007 msg := DKLangConstW('uTemplateFields_Field_Name_must_be_at_least_three_characters_in_length') //kt added 8/8/2007 else if(not (Fld.FldName[1] in ['A'..'Z','0'..'9'])) then // msg := 'First Field Name character must be "A" - "Z", or "0" - "9"' <-- original line. //kt 8/8/2007 msg := DKLangConstW('uTemplateFields_First_Field_Name_character_must_be_xAx_x_xZxx_or_x0x_x_x9x') //kt added 8/8/2007 else if(assigned(uTmplFlds)) then begin for i := 0 to uTmplFlds.Count-1 do begin if(Fld <> uTmplFlds[i]) and (CompareText(TTemplateField(uTmplFlds[i]).FFldName, Fld.FFldName) = 0) then begin msg := DUPFLD; break; end; end; end; if(msg = '') and (not IsTemplateFieldNameUnique(Fld.FFldName, Fld.ID)) then msg := DUPFLD; Result := (msg <> ''); if(Result) then ShowMessage(msg); end; function SaveTemplateFieldErrors: string; var i: integer; Errors: TStringList; Fld: TTemplateField; msg: string; begin Result := ''; if(assigned(uTmplFlds)) then begin Errors := nil; try for i := 0 to uTmplFlds.Count-1 do begin Fld := TTemplateField(uTmplFlds[i]); if(Fld.FModified) then begin msg := Fld.SaveError; if(msg <> '') then begin if(not assigned(Errors)) then begin Errors := TStringList.Create; // Errors.Add('The following template field save errors have occurred:'); <-- original line. //kt 8/8/2007 Errors.Add(DKLangConstW('uTemplateFields_The_following_template_field_save_errors_have_occurredx')); //kt added 8/8/2007 Errors.Add(''); end; Errors.Add(' ' + Fld.FldName + ': ' + msg); end; end; end; finally if(assigned(Errors)) then begin Result := Errors.Text; Errors.Free; end; end; end; end; procedure ClearModifiedTemplateFields; var i: integer; Fld: TTemplateField; begin if(assigned(uTmplFlds)) then begin for i := uTmplFlds.Count-1 downto 0 do begin Fld := TTemplateField(uTmplFlds[i]); if(assigned(Fld)) and (Fld.FModified) then begin if Fld.FLocked then UnlockTemplateField(Fld.FID); Fld.Free; end; end; end; end; function AnyTemplateFieldsModified: boolean; var i: integer; begin Result := FALSE; if(assigned(uTmplFlds)) then begin for i := 0 to uTmplFlds.Count-1 do begin if(TTemplateField(uTmplFlds[i]).FModified) then begin Result := TRUE; break; end; end; end; end; procedure ListTemplateFields(const AText: string; AList: TStrings; ListErrors: boolean = FALSE); var i, j, k, flen, BadCount: integer; flddesc, tmp, fld: string; TmpList: TStringList; InactiveList: TStringList; FldObj: TTemplateField; begin if(AText = '') then exit; BadCount := 0; InactiveList := TStringList.Create; try TmpList := TStringList.Create; try TmpList.Text := AText; for k := 0 to TmpList.Count-1 do begin tmp := TmpList[k]; repeat i := pos(TemplateFieldBeginSignature, tmp); if(i > 0) then begin fld := ''; j := pos(TemplateFieldEndSignature, copy(tmp, i + TemplateFieldSignatureLen, MaxInt)); if(j > 0) then begin inc(j, i + TemplateFieldSignatureLen - 1); flen := j - i - TemplateFieldSignatureLen; fld := copy(tmp,i + TemplateFieldSignatureLen, flen); delete(tmp, i, flen + TemplateFieldSignatureLen + 1); end else begin delete(tmp,i,TemplateFieldSignatureLen); inc(BadCount); end; if(fld <> '') then begin if ListErrors then begin FldObj := GetTemplateField(fld, FALSE); if assigned(FldObj) then begin if FldObj.Inactive then InactiveList.Add(' "' + fld + '"'); flddesc := ''; end else flddesc := ' "' + fld + '"'; end else flddesc := fld; if(flddesc <> '') and (AList.IndexOf(flddesc) < 0) then AList.Add(flddesc) end; end; until (i = 0); end; finally TmpList.Free; end; if ListErrors then begin if(AList.Count > 0) then // AList.Insert(0, 'The following template fields were not found:'); <-- original line. //kt 8/8/2007 AList.Insert(0, DKLangConstW('uTemplateFields_The_following_template_fields_were_not_foundx')); //kt added 8/8/2007 if (BadCount > 0) then begin if(BadCount = 1) then // tmp := 'A template field marker "' + TemplateFieldBeginSignature + <-- original line. //kt 8/8/2007 tmp := DKLangConstW('uTemplateFields_A_template_field_marker_x') + TemplateFieldBeginSignature + //kt added 8/8/2007 // '" was found without a' <-- original line. //kt 8/8/2007 DKLangConstW('uTemplateFields_x_was_found_without_a') //kt added 8/8/2007 else // tmp := IntToStr(BadCount) + ' template field markers "' + TemplateFieldBeginSignature + <-- original line. //kt 8/8/2007 tmp := IntToStr(BadCount) + DKLangConstW('uTemplateFields_template_field_markers_x') + TemplateFieldBeginSignature + //kt added 8/8/2007 // '" were found without'; <-- original line. //kt 8/8/2007 DKLangConstW('uTemplateFields_x_were_found_without'); //kt added 8/8/2007 if(AList.Count > 0) then AList.Add(''); // AList.Add(tmp + ' matching "' + TemplateFieldEndSignature + '"'); <-- original line. //kt 8/8/2007 AList.Add(tmp + DKLangConstW('uTemplateFields_matching_x') + TemplateFieldEndSignature + '"'); //kt added 8/8/2007 end; if(InactiveList.Count > 0) then begin if(AList.Count > 0) then AList.Add(''); // AList.Add('The following inactive template fields were found:'); <-- original line. //kt 8/8/2007 AList.Add(DKLangConstW('uTemplateFields_The_following_inactive_template_fields_were_foundx')); //kt added 8/8/2007 AList.AddStrings(InactiveList); end; if(AList.Count > 0) then begin // AList.Insert(0, 'Text contains template field errors:'); <-- original line. //kt 8/8/2007 AList.Insert(0, DKLangConstW('uTemplateFields_Text_contains_template_field_errorsx')); //kt added 8/8/2007 AList.Insert(1, ''); end; end; finally InactiveList.Free; end; end; function BoilerplateTemplateFieldsOK(const AText: string; Msg: string = ''): boolean; var Errors: TStringList; btns: TMsgDlgButtons; begin Result := TRUE; Errors := TStringList.Create; try ListTemplateFields(AText, Errors, TRUE); if(Errors.Count > 0) then begin if(Msg = 'OK') then btns := [mbOK] else begin btns := [mbAbort, mbIgnore]; Errors.Add(''); if(Msg = '') then // Msg := 'text insertion'; <-- original line. //kt 8/8/2007 Msg := DKLangConstW('uTemplateFields_text_insertion'); //kt added 8/8/2007 // Errors.Add('Do you want to Abort ' + Msg + ', or Ignore the error and continue?'); <-- original line. //kt 8/8/2007 Errors.Add(DKLangConstW('uTemplateFields_Do_you_want_to_Abort')+' ' + Msg + DKLangConstW('uTemplateFields_x_or_Ignore_the_error_and_continuex')); //kt added 8/8/2007 end; Result := (MessageDlg(Errors.Text, mtError, btns, 0) = mrIgnore); end; finally Errors.Free; end; end; procedure EnsureText(edt: TEdit; ud: TUpDown); var v: integer; s: string; begin if assigned(ud.Associate) then begin v := StrToIntDef(edt.Text, ud.Position); if (v < ud.Min) or (v > ud.Max) then v := ud.Position; s := IntToStr(v); if edt.Text <> s then edt.Text := s; end; edt.SelStart := edt.GetTextLen; end; function TemplateFieldCode2Field(const Code: string): TTemplateFieldType; var typ: TTemplateFieldType; begin Result := dftUnknown; for typ := low(TTemplateFieldType) to high(TTemplateFieldType) do if Code = TemplateFieldTypeCodes[typ] then begin Result := typ; break; end; end; function TemplateDateCode2DateType(const Code: string): TTmplFldDateType; var typ: TTmplFldDateType; begin Result := dtUnknown; for typ := low(TTmplFldDateType) to high(TTmplFldDateType) do if Code = TemplateFieldDateCodes[typ] then begin Result := typ; break; end; end; procedure ConvertCodes2Text(sl: TStrings; Short: boolean); var i: integer; tmp, output: string; ftype: TTemplateFieldType; dtype: TTmplFldDateType; begin for i := 0 to sl.Count-1 do begin tmp := sl[i]; if piece(tmp,U,4) = BOOLCHAR[TRUE] then output := '* ' else output := ' '; ftype := TemplateFieldCode2Field(Piece(tmp, U, 3)); if ftype = dftDate then begin dtype := TemplateDateCode2DateType(Piece(tmp, U, 5)); //kt output := output + TemplateDateTypeDesc[dtype, short]; output := output + TemplateDateTypeDesc(dtype, short); end else //kt output := output + TemplateFieldTypeDesc[ftype, short]; output := output + TemplateFieldTypeDesc(ftype, short); SetPiece(tmp, U, 3, output); sl[i] := tmp; end; end; { TTemplateField } constructor TTemplateField.Create(AData: TStrings); var tmp, p1: string; AFID, i,idx,cnt: integer; begin AFID := 0; if(assigned(AData)) then begin if AData.Count > 0 then AFID := StrToIntDef(AData[0],0); if(AFID > 0) and (AData.Count > 1) then begin FID := IntToStr(AFID); FFldName := Piece(AData[1],U,1); FFldType := TemplateFieldCode2Field(Piece(AData[1],U,2)); FInactive := (Piece(AData[1],U,3) = '1'); FMaxLen := StrToIntDef(Piece(AData[1],U,4),0); FEditDefault := Piece(AData[1],U,5); FLMText := Piece(AData[1],U,6); idx := StrToIntDef(Piece(AData[1],U,7),0); cnt := 0; for i := 2 to AData.Count-1 do begin tmp := AData[i]; p1 := Piece(tmp,U,1); tmp := Piece(tmp,U,2); if(p1 = 'D') then FNotes := FNotes + tmp + CRLF else if(p1 = 'U') then FURL := tmp else if(p1 = 'I') then begin inc(cnt); FItems := FItems + tmp + CRLF; if(cnt=idx) then FItemDefault := tmp; end; end; FRequired := (Piece(AData[1],U,8) = '1'); FSepLines := (Piece(AData[1],U,9) = '1'); FTextLen := StrToIntDef(Piece(AData[1],U,10),0); FIndent := StrToIntDef(Piece(AData[1],U,11),0); FPad := StrToIntDef(Piece(AData[1],U,12),0); FMinVal := StrToIntDef(Piece(AData[1],U,13),0); FMaxVal := StrToIntDef(Piece(AData[1],U,14),0); FIncrement := StrToIntDef(Piece(AData[1],U,15),0); FDateType := TemplateDateCode2DateType(Piece(AData[1],U,16)); FModified := FALSE; FNameChanged := FALSE; end; end; if(AFID = 0) then begin inc(uNewTemplateFieldIDCnt); FID := IntToStr(-uNewTemplateFieldIDCnt); FFldName := NewTemplateField; FModified := TRUE; end; if(not assigned(uTmplFlds)) then uTmplFlds := TList.Create; uTmplFlds.Add(Self); end; function TTemplateField.GetTemplateFieldDefault: string; begin case FFldType of dftEditBox, dftNumber: Result := FEditDefault; dftComboBox, dftButton, dftCheckBoxes, {Clear out embedded fields} dftRadioButtons: Result := StripEmbedded(FItemDefault); dftDate: if FEditDefault <> '' then Result := FEditDefault; dftHyperlink, dftText: if FEditDefault <> '' then Result := StripEmbedded(FEditDefault) else Result := URL; dftWP: Result := Items; end; end; procedure TTemplateField.CreateDialogControls(Entry: TTemplateDialogEntry; var Index: Integer; CtrlID: integer); var i, Aht, w, tmp, AWdth: integer; STmp: string; TmpSL: TStringList; edt: TEdit; cbo: TORComboBox; cb: TORCheckBox; btn: TfraTemplateFieldButton; dbox: TORDateBox; dcbo: TORDateCombo; lbl: TFieldLabel; re: TRichEdit; pnl: TPanel; ud: TUpDown; DefDate: TFMDateTime; ctrl: TControl; function wdth: integer; begin if(Awdth < 0) then Awdth := FontWidthPixel(Entry.FFont.Handle); Result := Awdth; end; function ht: integer; begin if(Aht < 0) then Aht := FontHeightPixel(Entry.FFont.Handle); Result := Aht; end; procedure UpdateIndents(AControl: TControl); var idx: integer; begin if (FIndent > 0) or (FPad > 0) then begin idx := Entry.FIndents.IndexOfObject(AControl); if idx < 0 then Entry.FIndents.AddObject(IntToStr(FIndent * wdth) + U + IntToStr(FPad), AControl); end; end; begin if(not FInactive) and (FFldType <> dftUnknown) then begin AWdth := -1; Aht := -1; ctrl := nil; case FFldType of dftEditBox: begin edt := TEdit.Create(nil); edt.Parent := Entry.FPanel; edt.BorderStyle := bsNone; edt.Height := ht; edt.Width := (wdth * Width + 4); if FTextLen > 0 then edt.MaxLength := FTextLen else edt.MaxLength := FMaxLen; edt.Text := FEditDefault; edt.Tag := CtrlID; edt.OnChange := Entry.DoChange; ctrl := edt; end; dftComboBox: begin cbo := TORComboBox.Create(nil); cbo.Parent := Entry.FPanel; cbo.TemplateField := TRUE; w := Width; cbo.MaxLength := w; if FTextLen > 0 then cbo.MaxLength := FTextLen else cbo.ListItemsOnly := TRUE; {Clear out embedded fields} cbo.Items.Text := StripEmbedded(Items); cbo.SelectByID(StripEmbedded(FItemDefault)); cbo.Tag := CtrlID; cbo.OnClick := Entry.DoChange; if cbo.Items.Count > 12 then begin cbo.Width := (wdth * w) + ScrollBarWidth + 8; cbo.DropDownCount := 12; end else begin cbo.Width := (wdth * w) + 18; cbo.DropDownCount := cbo.Items.Count; end; ctrl := cbo; end; dftButton: begin btn := TfraTemplateFieldButton.Create(nil); btn.Parent := Entry.FPanel; {Clear out embedded fields} btn.Items.Text := StripEmbedded(Items); btn.ButtonText := StripEmbedded(FItemDefault); btn.Height := ht; btn.Width := (wdth * Width) + 6; btn.Tag := CtrlID; btn.OnChange := Entry.DoChange; ctrl := btn; end; dftCheckBoxes, dftRadioButtons: begin if FFldType = dftRadioButtons then inc(uRadioGroupIndex); TmpSL := TStringList.Create; try {Clear out embedded fields} TmpSL.Text := StripEmbedded(Items); for i := 0 to TmpSL.Count-1 do begin cb := TORCheckBox.Create(nil); cb.Parent := Entry.FPanel; cb.Caption := TmpSL[i]; cb.AutoSize := TRUE; cb.AutoAdjustSize; // cb.AutoSize := FALSE; // cb.Height := ht; if FFldType = dftRadioButtons then begin cb.GroupIndex := uRadioGroupIndex; cb.RadioStyle := TRUE; end; if(TmpSL[i] = StripEmbedded(FItemDefault)) then cb.Checked := TRUE; cb.Tag := CtrlID; if FSepLines and (FFldType in SepLinesTypes) then cb.StringData := NewLine; cb.OnClick := Entry.DoChange; inc(Index); Entry.FControls.InsertObject(Index, '', cb); if (i=0) or FSepLines then UpdateIndents(cb); end; finally TmpSL.Free; end; end; dftDate: begin if FEditDefault <> '' then DefDate := StrToFMDateTime(FEditDefault) else DefDate := 0; if FDateType in DateComboTypes then begin dcbo := TORDateCombo.Create(nil); dcbo.Parent := Entry.FPanel; dcbo.Tag := CtrlID; dcbo.IncludeBtn := (FDateType = dtCombo); dcbo.IncludeDay := (FDateType = dtCombo); dcbo.IncludeMonth := (FDateType <> dtYear); dcbo.FMDate := DefDate; dcbo.TemplateField := TRUE; dcbo.OnChange := Entry.DoChange; ctrl := dcbo; end else begin dbox := TORDateBox.Create(nil); dbox.Parent := Entry.FPanel; dbox.Tag := CtrlID; dbox.DateOnly := (FDateType = dtDate); dbox.RequireTime := (FDateType = dtDateReqTime); dbox.TemplateField := TRUE; dbox.FMDateTime := DefDate; if (FDateType = dtDate) then tmp := 11 else tmp := 17; dbox.Width := (wdth * tmp) + 18; dbox.OnChange := Entry.DoChange; ctrl := dbox; end; end; dftNumber: begin pnl := TPanel.Create(nil); pnl.Parent := Entry.FPanel; pnl.BevelOuter := bvNone; pnl.Tag := CtrlID; edt := TEdit.Create(pnl); edt.Parent := pnl; edt.BorderStyle := bsNone; edt.Height := ht; edt.Width := (wdth * 5 + 4); edt.Top := 0; edt.Left := 0; edt.AutoSelect := True; ud := TUpDown.Create(pnl); ud.Parent := pnl; ud.Associate := edt; ud.Min := MinVal; ud.Max := MaxVal; ud.Min := MinVal; // Both ud.Min settings are needeed! i := Increment; if i < 1 then i := 1; ud.Increment := i; ud.Thousands := FALSE; ud.Position := StrToIntDef(EditDefault, 0); edt.Tag := Integer(ud); edt.OnChange := Entry.UpDownChange; pnl.Height := edt.Height; pnl.Width := edt.Width + ud.Width; ctrl := pnl; end; dftHyperlink, dftText: begin if (FFldType = dftHyperlink) and User.WebAccess then lbl := TWebLabel.Create(nil) else lbl := TFieldLabel.Create(nil); lbl.Parent := Entry.FPanel; lbl.ShowAccelChar := FALSE; lbl.FExclude := FSepLines; if (FFldType = dftHyperlink) then begin if FEditDefault <> '' then lbl.Caption := StripEmbedded(FEditDefault) else lbl.Caption := URL; end else begin STmp := StripEmbedded(Items); if copy(STmp,length(STmp)-1,2) = CRLF then delete(STmp,length(STmp)-1,2); lbl.Caption := STmp; end; if lbl is TWebLabel then TWebLabel(lbl).Init(FURL); lbl.Tag := CtrlID; ctrl := lbl; end; dftWP: begin re := TRichEdit.Create(nil); re.Parent := Entry.FPanel; re.Tag := CtrlID; tmp := FMaxLen; if tmp < 5 then tmp := 5; re.Width := wdth * tmp; tmp := FTextLen; if tmp < 2 then tmp := 2 else if tmp > MaxTFWPLines then tmp := MaxTFWPLines; re.Height := ht * tmp; re.BorderStyle := bsNone; re.ScrollBars := ssVertical; re.Lines.Text := Items; re.OnChange := Entry.DoChange; ctrl := re; end; end; if assigned(ctrl) then begin inc(Index); Entry.FControls.InsertObject(Index, '', ctrl); UpdateIndents(ctrl); end; end; end; function TTemplateField.CanModify: boolean; begin if((not FModified) and (not FLocked) and (StrToIntDef(FID,0) > 0)) then begin FLocked := LockTemplateField(FID); Result := FLocked; if(not FLocked) then // ShowMessage('Template Field ' + FFldName + ' is currently being edited by another user.'); <-- original line. //kt 8/8/2007 ShowMessage(DKLangConstW('uTemplateFields_Template_Field')+' ' + FFldName + DKLangConstW('uTemplateFields_is_currently_being_edited_by_another_userx')); //kt added 8/8/2007 end else Result := TRUE; if(Result) then FModified := TRUE; end; procedure TTemplateField.SetEditDefault(const Value: string); begin if(FEditDefault <> Value) and CanModify then FEditDefault := Value; end; procedure TTemplateField.SetFldName(const Value: string); begin if(FFldName <> Value) and CanModify then begin FFldName := Value; FNameChanged := TRUE; end; end; procedure TTemplateField.SetFldType(const Value: TTemplateFieldType); begin if(FFldType <> Value) and CanModify then begin FFldType := Value; if(Value = dftEditBox) then begin if (FMaxLen < 1) then FMaxLen := 1; if FTextLen < FMaxLen then FTextLen := FMaxLen; end else if(Value = dftHyperlink) and (FURL = '') then FURL := 'http://' else if(Value = dftComboBox) and (FMaxLen < 1) then begin FMaxLen := Width; if FMaxLen < 1 then FMaxLen := 1; end else if(Value = dftWP) then begin if (FMaxLen = 0) then FMaxLen := MAX_ENTRY_WIDTH else if (FMaxLen < 5) then FMaxLen := 5; if FTextLen < 2 then FTextLen := 2; end else if(Value = dftDate) and (FDateType = dtUnknown) then FDateType := dtDate; end; end; procedure TTemplateField.SetID(const Value: string); begin // if(FID <> Value) and CanModify then FID := Value; end; procedure TTemplateField.SetInactive(const Value: boolean); begin if(FInactive <> Value) and CanModify then FInactive := Value; end; procedure TTemplateField.SetItemDefault(const Value: string); begin if(FItemDefault <> Value) and CanModify then FItemDefault := Value; end; procedure TTemplateField.SetItems(const Value: string); begin if(FItems <> Value) and CanModify then FItems := Value; end; procedure TTemplateField.SetLMText(const Value: string); begin if(FLMText <> Value) and CanModify then FLMText := Value; end; procedure TTemplateField.SetMaxLen(const Value: integer); begin if(FMaxLen <> Value) and CanModify then FMaxLen := Value; end; procedure TTemplateField.SetNotes(const Value: string); begin if(FNotes <> Value) and CanModify then FNotes := Value; end; function TTemplateField.SaveError: string; var TmpSL, FldSL: TStringList; AID,Res: string; idx, i: integer; IEN64: Int64; NewRec: boolean; begin if(FFldName = NewTemplateField) then begin // Result := 'Template Field can not be named "' + NewTemplateField + '"'; <-- original line. //kt 8/8/2007 Result := DKLangConstW('uTemplateFields_Template_Field_can_not_be_named_x') + NewTemplateField + '"'; //kt added 8/8/2007 exit; end; Result := ''; NewRec := (StrToIntDef(FID,0) < 0); if(FModified or NewRec) then begin TmpSL := TStringList.Create; try FldSL := TStringList.Create; try if(StrToIntDef(FID,0) > 0) then AID := FID else AID := '0'; FldSL.Add('.01='+FFldName); FldSL.Add('.02='+TemplateFieldTypeCodes[FFldType]); FldSL.Add('.03='+BOOLCHAR[FInactive]); FldSL.Add('.04='+IntToStr(FMaxLen)); FldSL.Add('.05='+FEditDefault); FldSL.Add('.06='+FLMText); idx := -1; if(FItems <> '') and (FItemDefault <> '') then begin TmpSL.Text := FItems; for i := 0 to TmpSL.Count-1 do if(FItemDefault = TmpSL[i]) then begin idx := i; break; end; end; FldSL.Add('.07='+IntToStr(Idx+1)); FldSL.Add('.08='+BOOLCHAR[fRequired]); FldSL.Add('.09='+BOOLCHAR[fSepLines]); FldSL.Add('.1=' +IntToStr(FTextLen)); FldSL.Add('.11='+IntToStr(FIndent)); FldSL.Add('.12='+IntToStr(FPad)); FldSL.Add('.13='+IntToStr(FMinVal)); FldSL.Add('.14='+IntToStr(FMaxVal)); FldSL.Add('.15='+IntToStr(FIncrement)); if FDateType = dtUnknown then FldSL.Add('.16=@') else FldSL.Add('.16='+TemplateFieldDateCodes[FDateType]); if FURL='' then FldSL.Add('3=@') else FldSL.Add('3='+FURL); if(FNotes <> '') or (not NewRec) then begin if(FNotes = '') then FldSL.Add('2,1=@') else begin TmpSL.Text := FNotes; for i := 0 to TmpSL.Count-1 do FldSL.Add('2,'+IntToStr(i+1)+',0='+TmpSL[i]); end; end; if((FItems <> '') or (not NewRec)) then begin if(FItems = '') then FldSL.Add('10,1=@') else begin TmpSL.Text := FItems; for i := 0 to TmpSL.Count-1 do FldSL.Add('10,'+IntToStr(i+1)+',0='+TmpSL[i]); end; end; Res := UpdateTemplateField(AID, FldSL); IEN64 := StrToInt64Def(Piece(Res,U,1),0); if(IEN64 > 0) then begin if(NewRec) then FID := IntToStr(IEN64) else UnlockTemplateField(FID); FModified := FALSE; FNameChanged := FALSE; FLocked := FALSE; end else Result := Piece(Res, U, 2); finally FldSL.Free; end; finally TmpSL.Free; end; end; end; procedure TTemplateField.Assign(AFld: TTemplateField); begin FMaxLen := AFld.FMaxLen; FFldName := AFld.FFldName; FLMText := AFld.FLMText; FEditDefault := AFld.FEditDefault; FNotes := AFld.FNotes; FItems := AFld.FItems; FInactive := AFld.FInactive; FItemDefault := AFld.FItemDefault; FFldType := AFld.FFldType; FRequired := AFld.FRequired; FSepLines := AFld.FSepLines; FTextLen := AFld.FTextLen; FIndent := AFld.FIndent; FPad := AFld.FPad; FMinVal := AFld.FMinVal; FMaxVal := AFld.FMaxVal; FIncrement := AFld.FIncrement; FDateType := AFld.FDateType; FURL := AFld.FURL; end; function TTemplateField.Width: integer; var i, ilen: integer; TmpSL: TStringList; begin if(FFldType = dftEditBox) then Result := FMaxLen else begin if FMaxLen > 0 then Result := FMaxLen else begin Result := -1; TmpSL := TStringList.Create; try TmpSL.Text := StripEmbedded(FItems); for i := 0 to TmpSL.Count-1 do begin ilen := length(TmpSL[i]); if(Result < ilen) then Result := ilen; end; finally TmpSL.Free; end; end; end; if Result > MaxTFEdtLen then Result := MaxTFEdtLen; end; destructor TTemplateField.Destroy; begin uTmplFlds.Remove(Self); inherited; end; procedure TTemplateField.SetRequired(const Value: boolean); begin if(FRequired <> Value) and CanModify then FRequired := Value; end; function TTemplateField.NewField: boolean; begin Result := (StrToIntDef(FID,0) <= 0); end; procedure TTemplateField.SetSepLines(const Value: boolean); begin if(FSepLines <> Value) and CanModify then FSepLines := Value end; procedure TTemplateField.SetIncrement(const Value: integer); begin if(FIncrement <> Value) and CanModify then FIncrement := Value; end; procedure TTemplateField.SetIndent(const Value: integer); begin if(FIndent <> Value) and CanModify then FIndent := Value; end; procedure TTemplateField.SetMaxVal(const Value: integer); begin if(FMaxVal <> Value) and CanModify then FMaxVal := Value; end; procedure TTemplateField.SetMinVal(const Value: integer); begin if(FMinVal <> Value) and CanModify then FMinVal := Value; end; procedure TTemplateField.SetPad(const Value: integer); begin if(FPad <> Value) and CanModify then FPad := Value; end; procedure TTemplateField.SetTextLen(const Value: integer); begin if(FTextLen <> Value) and CanModify then FTextLen := Value; end; procedure TTemplateField.SetURL(const Value: string); begin if(FURL <> Value) and CanModify then FURL := Value; end; function TTemplateField.GetRequired: boolean; begin if FFldType in NoRequired then Result := FALSE else Result := FRequired; end; procedure TTemplateField.SetDateType(const Value: TTmplFldDateType); begin if(FDateType <> Value) and CanModify then FDateType := Value; end; { TTemplateDialogEntry } const EOL_MARKER = #182; procedure PanelDestroy(AData: Pointer; Sender: TObject); var idx: integer; dlg: TTemplateDialogEntry; begin dlg := TTemplateDialogEntry(AData); idx := uEntries.IndexOf(dlg.FID); if(idx >= 0) then uEntries.Delete(idx); dlg.FPanelDying := TRUE; dlg.Free; end; constructor TTemplateDialogEntry.Create(AParent: TWinControl; AID, Text: string); var CtrlID, idx, i, j, flen: integer; txt, FldName: string; Fld: TTemplateField; begin FID := AID; FText := Text; FHTMLMode := false; //kt added 12/28/09 FControls := TStringList.Create; FIndents := TStringList.Create; FFont := TFont.Create; FFont.Assign(TORExposedControl(AParent).Font); FControls.Text := Text; if(FControls.Count > 1) then for i := 1 to FControls.Count-1 do FControls[i] := EOL_MARKER + FControls[i]; FFirstBuild := TRUE; FPanel := TFieldPanel.Create(AParent.Owner); FPanel.Parent := AParent; FPanel.BevelOuter := bvNone; FPanel.Caption := ''; FPanel.Font.Assign(FFont); idx := 0; while (idx < FControls.Count) do begin txt := FControls[idx]; i := pos(TemplateFieldBeginSignature, txt); if(i > 0) then begin if(copy(txt, i + TemplateFieldSignatureLen, 1) = FieldIDDelim) then begin CtrlID := StrToIntDef(copy(txt, i + TemplateFieldSignatureLen + 1, FieldIDLen-1), 0); delete(txt,i + TemplateFieldSignatureLen, FieldIDLen); end else CtrlID := 0; j := pos(TemplateFieldEndSignature, copy(txt, i + TemplateFieldSignatureLen, MaxInt)); if(j > 0) then begin inc(j, i + TemplateFieldSignatureLen - 1); flen := j - i - TemplateFieldSignatureLen; FldName := copy(txt, i + TemplateFieldSignatureLen, flen); Fld := GetTemplateField(FldName, FALSE); delete(txt,i,flen + TemplateFieldSignatureLen + 1); if(assigned(Fld)) then begin FControls[idx] := copy(txt,1,i-1); if(Fld.Required) then FControls[idx] := FControls[idx] + '*'; Fld.CreateDialogControls(Self, idx, CtrlID); FControls.Insert(idx+1,copy(txt,i,MaxInt)); end else begin FControls[idx] := txt; dec(idx); end; end else begin delete(txt,i,TemplateFieldSignatureLen); FControls[idx] := txt; dec(idx); end; end; inc(idx); end; end; destructor TTemplateDialogEntry.Destroy; begin if assigned(FOnDestroy) then FOnDestroy(Self); KillLabels; KillObj(@FControls, TRUE); if FPanelDying then FPanel := nil else FreeAndNil(FPanel); FreeAndNil(FFont); FreeAndNil(FIndents); inherited; end; procedure TTemplateDialogEntry.DoChange(Sender: TObject); begin if (not FUpdating) and assigned(FOnChange) then FOnChange(Self); end; function TTemplateDialogEntry.GetControlText(CtrlID: integer; NoCommas: boolean; var FoundEntry: boolean; AutoWrap: boolean; emField: string = ''): string; var x, i, j, ind, idx: integer; Ctrl: TControl; Done: boolean; iString: string; iField: TTemplateField; iTemp: TStringList; function GetOriginalItem(istr: string): string; begin Result := ''; if emField <> '' then begin iField := GetTemplateField(emField,FALSE); iTemp := nil; if ifield <> nil then try iTemp := TStringList.Create; iTemp.Text := StripEmbedded(iField.Items); x := iTemp.IndexOf(istr); if x >= 0 then begin iTemp.Text := iField.Items; Result := iTemp.Strings[x]; end; finally iTemp.Free; end; end; end; begin Result := ''; Done := FALSE; ind := -1; for i := 0 to FControls.Count-1 do begin Ctrl := TControl(FControls.Objects[i]); if(assigned(Ctrl)) and (Ctrl.Tag = CtrlID) then begin FoundEntry := TRUE; Done := TRUE; if ind < 0 then begin idx := FIndents.IndexOfObject(Ctrl); if idx >= 0 then ind := StrToIntDef(Piece(FIndents[idx], U, 2), 0) else ind := 0; end; if(Ctrl is TFieldLabel) then begin if not TFieldLabel(Ctrl).Exclude then begin if emField <> '' then begin iField := GetTemplateField(emField,FALSE); case iField.FldType of dftHyperlink: if iField.EditDefault <> '' then Result := iField.EditDefault else Result := iField.URL; dftText: begin iString := iField.Items; if copy(iString,length(iString)-1,2) = CRLF then delete(iString,length(iString)-1,2); Result := iString; end; else {case} Result := TFieldLabel(Ctrl).Caption end; {case iField.FldType} end {if emField} else Result := TFieldLabel(Ctrl).Caption; end; end else if(Ctrl is TEdit) then Result := TEdit(Ctrl).Text else if(Ctrl is TORComboBox) then begin Result := TORComboBox(Ctrl).Text; iString := GetOriginalItem(Result); if iString <> '' then Result := iString; end else if(Ctrl is TORDateCombo) then Result := TORDateCombo(Ctrl).Text + ':' + FloatToStr(TORDateCombo(Ctrl).FMDate) else if(Ctrl is TORDateBox) then Result := TORDateBox(Ctrl).Text else if(Ctrl is TRichEdit) then begin if((ind = 0) and (not AutoWrap)) then Result := TRichEdit(Ctrl).Lines.Text else begin for j := 0 to TRichEdit(Ctrl).Lines.Count-1 do begin if AutoWrap then begin if(Result <> '') then Result := Result + ' '; Result := Result + TRichEdit(Ctrl).Lines[j]; end else begin if(Result <> '') then Result := Result + CRLF; Result := Result + StringOfChar(' ', ind) + TRichEdit(Ctrl).Lines[j]; end; end; ind := 0; end; end else if(Ctrl is TORCheckBox) then begin Done := FALSE; if(TORCheckBox(Ctrl).Checked) then begin if(Result <> '') then begin if NoCommas then Result := Result + '|' else Result := Result + ', '; end; iString := GetOriginalItem(TORCheckBox(Ctrl).Caption); if iString <> '' then Result := Result + iString else Result := Result + TORCheckBox(Ctrl).Caption; end; end else if(Ctrl is TfraTemplateFieldButton) then begin Result := TfraTemplateFieldButton(Ctrl).ButtonText; iString := GetOriginalItem(Result); if iString <> '' then Result := iString; end else if(Ctrl is TPanel) then begin for j := 0 to Ctrl.ComponentCount-1 do if Ctrl.Components[j] is TUpDown then begin Result := IntToStr(TUpDown(Ctrl.Components[j]).Position); break; end; end; end; if Done then break; end; if (ind > 0) and (not NoCommas) then Result := StringOfChar(' ', ind) + Result; end; function TTemplateDialogEntry.GetFieldValues: string; var i: integer; Ctrl: TControl; CtrlID: integer; TmpIDs: TList; TmpSL: TStringList; Dummy: boolean; begin Result := ''; TmpIDs := TList.Create; try TmpSL := TStringList.Create; try for i := 0 to FControls.Count-1 do begin Ctrl := TControl(FControls.Objects[i]); if(assigned(Ctrl)) then begin CtrlID := Ctrl.Tag; if(TmpIDs.IndexOf(Pointer(CtrlID)) < 0) then begin TmpSL.Add(IntToStr(CtrlID) + U + GetControlText(CtrlID, TRUE, Dummy, FALSE)); TmpIDs.Add(Pointer(CtrlID)); end; end; end; Result := TmpSL.CommaText; finally TmpSL.Free; end; finally TmpIDs.Free; end; end; function TTemplateDialogEntry.GetPanel(MaxLen: integer; AParent: TWinControl): TPanel; var i, x, y, cnt, idx, ind, yinc, ybase, MaxX: integer; MaxTextLen: integer; {Max num of chars per line in pixels} MaxChars: integer; {Max num of chars per line} txt: string; ctrl: TControl; LastLineBlank: boolean; const FOCUS_RECT_MARGIN = 2; {The margin around the panel so the label won't overlay the focus rect on its parent panel.} procedure DoLabel(Atxt: string); var lbl: TLabel; begin lbl := TLabel.Create(nil); lbl.Parent := FPanel; lbl.ShowAccelChar := FALSE; lbl.Caption := Atxt; lbl.Left := x; lbl.Top := y; inc(x, lbl.Width); end; procedure NextLine; begin if(MaxX < x) then MaxX := x; x := FOCUS_RECT_MARGIN; {leave two pixels on the left for the Focus Rect} inc(y, yinc); yinc := ybase; end; begin MaxTextLen := MaxLen - (FOCUS_RECT_MARGIN * 2);{save room for the focus rectangle on the panel} if(FFirstBuild or (FPanel.Width <> MaxLen)) then begin if(FFirstBuild) then FFirstBuild := FALSE else KillLabels; y := FOCUS_RECT_MARGIN; {placement of labels on panel so they don't cover the} x := FOCUS_RECT_MARGIN; {focus rectangle} MaxX := 0; //ybase := FontHeightPixel(FFont.Handle) + 1 + (FOCUS_RECT_MARGIN * 2); AGP commentout line for //reminder spacing ybase := FontHeightPixel(FFont.Handle); yinc := ybase; LastLineBlank := FALSE; for i := 0 to FControls.Count-1 do begin txt := FControls[i]; if(copy(txt,1,1) = EOL_MARKER) then begin if((x <> 0) or LastLineBlank) then NextLine; delete(txt,1,1); LastLineBlank := (txt = ''); end; if(txt <> '') then begin while(txt <> '') do begin cnt := NumCharsFitInWidth(FFont.Handle, txt, MaxTextLen-x); MaxChars := cnt; if(cnt >= length(txt)) then begin DoLabel(txt); txt := ''; end else if(cnt < 1) then NextLine else begin repeat if(txt[cnt+1] = ' ') then begin DoLabel(copy(txt,1,cnt)); NextLine; txt := copy(txt, cnt + 1, MaxInt); break; end else dec(cnt); until(cnt = 0); if(cnt = 0) then begin if(x = FOCUS_RECT_MARGIN) then {If x is at the far left margin...} begin DoLabel(Copy(txt,1,MaxChars)); NextLine; txt := copy(txt, MaxChars + 1, MaxInt); end else NextLine; end; end; end; end else begin ctrl := TControl(FControls.Objects[i]); if(assigned(ctrl)) then begin idx := FIndents.IndexOfObject(Ctrl); if idx >= 0 then ind := StrToIntDef(Piece(FIndents[idx], U, 1), 0) else ind := 0; if(x > 0) then begin if (x < MaxLen) and (Ctrl is TORCheckBox) and (TORCheckBox(Ctrl).StringData = NewLine) then x := MaxLen; if((ctrl.Width + x + ind) > MaxLen) then NextLine; end; inc(x,ind); Ctrl.Left := x; Ctrl.Top := y; inc(x, Ctrl.Width + 4); if yinc <= Ctrl.Height then yinc := Ctrl.Height + 1; if (x < MaxLen) and ((Ctrl is TRichEdit) or ((Ctrl is TLabel) and (pos(CRLF, TLabel(Ctrl).Caption) > 0))) then x := MaxLen; end; end; end; NextLine; FPanel.Height := (y-1) + (FOCUS_RECT_MARGIN * 2); //AGP added Focus_rect_margin for Reminder spacing FPanel.Width := MaxX + FOCUS_RECT_MARGIN; end; if(FFieldValues <> '') then SetFieldValues(FFieldValues); Result := FPanel; end; procedure TTemplateDialogEntry.SetAnswerHTMLTag(Value : string); //kt 12/28/09 Added entire function begin if Value='' then begin FAnswerOpenTag :=''; FAnswerCloseTag := ''; end else begin if Pos('<',Value)>0 then Value := Piece(Value,'<',2); if Pos('>',Value)>0 then Value := Piece(Value,'>',1); FAnswerOpenTag :='<'+Value+'>'; FAnswerCloseTag := ''; end; end; function TTemplateDialogEntry.GetText: string; begin //kt Result := ResolveTemplateFields(FText, FALSE); Result := ResolveTemplateFields(FText, FALSE, FALSE, FALSE, FHTMLMode, FAnswerOpenTag, FAnswerCloseTag); //kt 12/29/09 end; procedure TTemplateDialogEntry.KillLabels; var i, idx: integer; obj: TObject; begin if(assigned(FPanel)) then begin for i := FPanel.ControlCount-1 downto 0 do if(FPanel.Controls[i] is TLabel) then begin obj := FPanel.Controls[i]; idx := FControls.IndexOfObject(obj); if idx < 0 then obj.Free; end; end; end; procedure TTemplateDialogEntry.SetAutoDestroyOnPanelFree( const Value: boolean); var M: TMethod; begin FAutoDestroyOnPanelFree := Value; if(Value) then begin M.Data := Self; M.Code := @PanelDestroy; TFieldPanel(FPanel).OnDestroy := TNotifyEvent(M); end else TFieldPanel(FPanel).OnDestroy := nil; end; procedure TTemplateDialogEntry.SetControlText(CtrlID: integer; AText: string); var cnt, i, j: integer; Ctrl: TControl; Done: boolean; begin FUpdating := TRUE; try Done := FALSE; cnt := 0; for i := 0 to FControls.Count-1 do begin Ctrl := TControl(FControls.Objects[i]); if(assigned(Ctrl)) and (Ctrl.Tag = CtrlID) then begin Done := TRUE; if(Ctrl is TLabel) then TLabel(Ctrl).Caption := AText else if(Ctrl is TEdit) then TEdit(Ctrl).Text := AText else if(Ctrl is TORComboBox) then TORComboBox(Ctrl).SelectByID(AText) else if(Ctrl is TRichEdit) then TRichEdit(Ctrl).Lines.Text := AText else if(Ctrl is TORDateCombo) then TORDateCombo(Ctrl).FMDate := MakeFMDateTime(piece(AText,':',2)) else if(Ctrl is TORDateBox) then TORDateBox(Ctrl).Text := AText else if(Ctrl is TORCheckBox) then begin Done := FALSE; if(cnt = 0) then cnt := DelimCount(AText, '|') + 1; for j := 1 to cnt do begin if(TORCheckBox(Ctrl).Caption = piece(AText,'|',j)) then TORCheckBox(Ctrl).Checked := TRUE; end; end else if(Ctrl is TfraTemplateFieldButton) then TfraTemplateFieldButton(Ctrl).ButtonText := AText else if(Ctrl is TPanel) then begin for j := 0 to Ctrl.ComponentCount-1 do if Ctrl.Components[j] is TUpDown then begin TUpDown(Ctrl.Components[j]).Position := StrToIntDef(AText,0); break; end; end; end; if Done then break; end; finally FUpdating := FALSE; end; end; procedure TTemplateDialogEntry.SetFieldValues(const Value: string); var i: integer; TmpSL: TStringList; begin FFieldValues := Value; TmpSL := TStringList.Create; try TmpSL.CommaText := Value; for i := 0 to TmpSL.Count-1 do SetControlText(StrToIntDef(Piece(TmpSL[i], U, 1), 0), Piece(TmpSL[i], U, 2)); finally TmpSL.Free; end; end; procedure TTemplateDialogEntry.UpDownChange(Sender: TObject); begin EnsureText(TEdit(Sender), TUpDown(TEdit(Sender).Tag)); DoChange(Sender); end; { TFieldPanel } destructor TFieldPanel.Destroy; begin if(assigned(FOnDestroy)) then FOnDestroy(Self); inherited; end; {intercept the paint event to draw the focus rect if FFocused is true} function TFieldPanel.GetFocus: boolean; begin result := Focused; end; procedure TFieldPanel.Paint; var DC: HDC; R: TRect; begin inherited; if(Focused) then begin if(not assigned(FCanvas)) then FCanvas := TControlCanvas.Create; DC := GetWindowDC(Handle); try FCanvas.Handle := DC; R := ClientRect; InflateRect(R, -1, -1); FCanvas.DrawFocusRect(R); finally ReleaseDC(Handle, DC); end; end; end; procedure TFieldPanel.SetTheFocus(const Value: boolean); begin if Value then SetFocus; end; { TWebLabel } procedure TWebLabel.Clicked(Sender: TObject); begin GotoWebPage(FAddr); end; procedure TWebLabel.Init(Addr: string); begin FAddr := Addr; OnClick := Clicked; Font.Assign(TORExposedControl(Parent).Font); Font.Color := clActiveCaption; Font.Style := Font.Style + [fsUnderline]; AdjustBounds; // make sure we have the right width AutoSize := FALSE; Height := Height + 1; // Courier New doesn't support underline unless it's higher Cursor := crHandPoint; end; function StripEmbedded(iItems: string): string; {7/26/01 S Monson Returns the field will all embedded fields removed} var p1, p2, icur: integer; Begin p1 := pos(TemplateFieldBeginSignature,iItems); icur := 0; while p1 > 0 do begin p2 := pos(TemplateFieldEndSignature,copy(iItems,icur+p1+TemplateFieldSignatureLen,maxint)); if p2 > 0 then begin delete(iItems,p1+icur,TemplateFieldSignatureLen+p2+TemplateFieldSignatureEndLen-1); icur := icur + p1 - 1; p1 := pos(TemplateFieldBeginSignature,copy(iItems,icur+1,maxint)); end else p1 := 0; end; Result := iItems; end; function EvaluateFormula(formula : string): string; begin //CloseCharPos(OpenChar, CloseChar : char; var Txt : string; StartingPos : integer=1) : integer; end; function FormatFormula(test: string): string; var test2: string; i: integer; begin for i := 1 to length(test) do begin if test[i] in ['0'..'9','+','-','*','/','(',')','^'] then begin test2 := test2 + test[i]; end; end; Result := test2; end; initialization finalization KillObj(@uTmplFlds, TRUE); KillObj(@uEntries, TRUE); end.