Hello
We are using this workflow code to protect the comemnts field from deletion or edited. This is working for us in QC 10, and now using the same wf code for v.11 patch 15, this will NOT allow non-tdamin users to enter the comment at all as the error will block user with msg "Previous comments cannot be modified! Previous comments have been restored!"
As a tdadmin, i can enter and remove comments fine.
Is this a casting issue with vbs(kb)? Help be greatly appreciated.
Function Defects_ActionCanExecute(ActionName) On Error Resume Next Defects_ActionCanExecute = Project_DefaultRes
If ActionName="BugAddDevCommentsAction1" then dim DescriptionBefore dim ServerTime dim UserStr
DescriptionBefore = Bug_Fields("BG_DEV_COMMENTS").Value if Len(DescriptionBefore) = 0 then DescriptionBefore = "<html><body>" else DescriptionBefore = Left(DescriptionBefore, Len(DescriptionBefore)-Len("</body></html>")) end if
UserStr = User.FullName if Trim(UserStr) = "" then UserStr = User.UserName end if
ServerTime = CStr(TDConnection.ServerTime)
' start R&D comments ' start R&D comments if DescriptionBefore = "<html><body>" then DescriptionBefore = DescriptionBefore + "<font color=""#000080""><b>" else DescriptionBefore = DescriptionBefore + "<br><font color=""#000080""><b>________________________________________<br>" end if DescriptionBefore = DescriptionBefore + UserStr + ", " DescriptionBefore = DescriptionBefore + ""+ServerTime+"" DescriptionBefore = DescriptionBefore + ":</b></font> " + "<br>"
'End R&D Comments
DescriptionBefore = DescriptionBefore + "</body></html>" Bug_Fields("BG_DEV_COMMENTS").Value = DescriptionBefore Defects_ActionCanExecute = False End If On Error GoTo 0 End Function
DescriptionBefore = DescriptionBefore + UserStr + ", " DescriptionBefore = DescriptionBefore + ""+ServerTime+"" DescriptionBefore = DescriptionBefore + ":</b></font> " + "<br>"
'END R&D Comments
DescriptionBefore = DescriptionBefore + "</body></html>" Bug_Fields("BG_DEV_COMMENTS").Value = DescriptionBefore Defects_ActionCanExecute = FALSE END IF On Error GoTo 0
END Function
Function LastValue(FieldName)
dim com dim rec dim td
if Bug_Fields("BG_BUG_ID").IsNull then LastValue = "" exit function end if
set td = TDConnection set com = td.Command com.CommandText = "select " & FieldName & " from BUG where BG_BUG_ID=" & Bug_Fields("BG_BUG_ID").Value set rec = com.Execute rec.First
LastValue = rec.FieldValue(Cstr(FieldName))
set com = nothing set rec = nothing set td = nothing
End Function
'Code example from http://www.codeproject.com/asp/removehtml.asp?print=true Function RemoveHTML( strText ) Dim TAGLIST TAGLIST = ";!--;!DOCTYPE;A;ACRONYM;ADDRESS;APPLET;AREA;BASE;BASEFONT;" &_ "BGSOUND;BIG;BLOCKQUOTE;BODY;BUTTON;CAPTION;CENTER;CITE;CODE;" &_ "COL;COLGROUP;COMMENT;DD;DEL;DFN;DIR;DIV;DL;DT;EM;EMBED;FIELDSET;" &_ "FORM;FRAME;FRAMESET;HEAD;H1;H2;H3;H4;H5;H6;HR;HTML;IFRAME;IMG;" &_ "INPUT;INS;ISINDEX;KBD;LABEL;LAYER;LAGEND;LI;LINK;LISTING;MAP;MARQUEE;" &_ "MENU;META;NOBR;NOFRAMES;NOSCRIPT;OBJECT;OL;OPTION;P;PARAM;PLAINTEXT;" &_ "PRE;Q;S;SAMP;SCRIPT;SELECT;SMALL;SPAN;STRIKE;STRONG;STYLE;SUB;SUP;" &_ "TABLE;TBODY;TD;TEXTAREA;TFOOT;TH;THEAD;TITLE;TR;TT;UL;VAR;WBR;XMP;FONT;BR;B;"
Const BLOCKTAGLIST = ";APPLET;EMBED;FRAMESET;HEAD;NOFRAMES;NOSCRIPT;OBJECT;SCRIPT;STYLE;"
Dim nPos1 Dim nPos2 Dim nPos3 Dim strResult Dim strTagName Dim bRemove Dim bSearchForBlock
nPos1 = InStr(strText, "<") Do While nPos1 > 0 nPos2 = InStr(nPos1 + 1, strText, ">") If nPos2 > 0 Then strTagName = Mid(strText, nPos1 + 1, nPos2 - nPos1 - 1) strTagName = Replace(Replace(strTagName, vbCr, " "), vbLf, " ")
nPos3 = InStr(strTagName, " ") If nPos3 > 0 Then strTagName = Left(strTagName, nPos3 - 1) End If
If Left(strTagName, 1) = "/" Then strTagName = Mid(strTagName, 2) bSearchForBlock = False Else bSearchForBlock = True End If
If InStr(1, TAGLIST, ";" & strTagName & ";", vbTextCompare) > 0 Then bRemove = True If bSearchForBlock Then If InStr(1, BLOCKTAGLIST, ";" & strTagName & ";", vbTextCompare) > 0 Then nPos2 = Len(strText) nPos3 = InStr(nPos1 + 1, strText, "</" & strTagName, vbTextCompare) If nPos3 > 0 Then nPos3 = InStr(nPos3 + 1, strText, ">") End If
If nPos3 > 0 Then nPos2 = nPos3 End If End If End If Else bRemove = False End If
If bRemove Then strResult = strResult & Left(strText, nPos1 - 1) strText = Mid(strText, nPos2 + 1) Else strResult = strResult & Left(strText, nPos1) strText = Mid(strText, nPos1 + 1) End If Else strResult = strResult & strText strText = "" End If
nPos1 = InStr(strText, "<") Loop strResult = strResult & strText
RemoveHTML = strResult
End Function
Sub Defects_Bug_FieldChange(FieldName)
On Error Resume Next
if not User.IsInGroup("tdadmin") then ' Code added for TDAdmin override ''here comment removal dim PreviousRD dim PreviousRDHTML dim CurrentRD dim PreLength dim original
if FieldName = "BG_DEV_COMMENTS" then PreviousRDHTML = Cstr(LastValue(FieldName)) 'Previous value before the user changed R&D Comments. original = PreviousRDHTML
PreviousRD = RemoveHTML(PreviousRDHTML) 'Remove HTML and Body tag PreLength = Len(PreviousRD) 'Length of original R&D comments. CurrentRD = RemoveHTML(Bug_Fields("BG_DEV_COMMENTS").Value) 'Current value of R&D Comments
'If the first part of the R&D Comments do not match the original R&D Comments, 'set the R&D Comments back to the original value and give a warning. if not (PreviousRD = Left(CStr(CurrentRD), PreLength)) then MsgBox("Previous comments cannot be modified! Previous comments have been restored!") MsgBox("Please use 'Add Comment' to add additional comments where your name and current timestamp are displayed.") Bug_Fields("BG_DEV_COMMENTS").Value = original
end if end if end if
On Error GoTo 0 End Sub