The function below is used to debug LCFieldList issues. Call the function like:
Set fldLst = New LCFieldList
. . . (after the select is run)
Print Cstr ( DebugStr(fldLst, True) )
Function:
Function DebugStr(vel As Variant, Byval brief As Boolean) As Variant
' This function takes any variant or object and returns a string describing its value.
' E.g. a string type is converted to a string enclosed in quotes, a date or number is
' simply converted to its default string representation, and there are special notations
' for arrays and lists. For any object, the type name of the object is shown.
On Error Goto oops
Dim result$, cc$
Dim i%
If Isarray(vel) Then
Forall values In vel
result$ = result$ & ", " & DebugStr(values, brief)
End Forall
DebugStr= "(" + Mid$(result$, 3) + ")"
Elseif Islist(vel) Then
Forall lvalues In vel
result$ = result$ + ", " + Listtag(lvalues) + "|" + DebugStr(lvalues, brief)
End Forall
DebugStr= "{" + Mid$(result$, 3) + "}"
Else
Select Case Datatype(vel)
Case 0 ' EMPTY
DebugStr= "EMPTY"
Case 1 ' NULL
DebugStr= Null
Case 2, 3, 4, 5, 6, 7 ' any number or date
DebugStr= Cstr(vel)
Case 8 ' String
DebugStr= """"
For i% = 1 To Len(vel)
cc$ = Mid$(vel, i%, 1)
Select Case cc$
Case """", "\"
DebugStr = DebugStr & "\" & cc$
Case "a" To "z", "A" To "Z", "0" To "9"
DebugStr = DebugStr & cc$
Case Else
If Instr(".,`~/?;:'|{}[]=+-_)(*&^%$# @!", cc$) Then
DebugStr = DebugStr + cc$
Else
DebugStr = DebugStr & "\" & Uni(cc$) & "."
End If
End Select
Next
DebugStr = DebugStr + """"
Case 9 ' OLE object or NOTHING
If vel Is Nothing Then
DebugStr= "NOTHING"
Else
DebugStr= "OLE Object"
End If
Case 10 ' OLE error
DebugStr= "OLE Error"
Case 11 ' Boolean
If vel Then
DebugStr= "True"
Else
DebugStr= "False"
End If
Case Else
DebugStr= Typename(vel)
Select Case Typename(vel)
Case "NOTESDOCUMENT"
DebugStr = DebugStr & " noteID=" & vel.noteid
Case "NOTESVIEW"
DebugStr = DebugStr & {(} & vel.name & {)}
Case "NOTESDOCUMENTCOLLECTION"
DebugStr = DebugStr & {(} & vel.count & {)}
Case "LCFIELDLIST"
result = ""
For i = 1 To vel.FieldCount
result = result & ", " & vel.GetName(i) & "=" & DebugStr(vel.GetField(i), brief)
Next
If brief Then
DebugStr = Mid$(result, 3)
Else
DebugStr = "FL<" & Mid$(result, 3) & ">"
End If
Case "LCFIELD"
debugStr = debugStrLCField(vel, brief)
Case "LCCONNECTION"
debugStr = debugStr & {< } & debugProperties(vel) & { >}
End Select
End Select
End If
Exit Function
oops:
debugStr = "error " & Err & " line " & Erl & ": " & Error
Exit Function
End Function
Function debugFMTName(ffmt As Long) As String
Select Case ffmt
Case LCSTREAMFMT_BLOB
debugFMTName = "BLOB"
Case LCSTREAMFMT_COMPOSITE
debugFMTName = "COMPOSITE"
Case LCSTREAMFMT_TEXT_LIST
debugFMTName = "TEXTLIST"
Case LCSTREAMFMT_NUMBER_LIST
debugFMTName = "NUMBERLIST"
Case LCSTREAMFMT_DATETIME_LIST
debugFMTName = "DATETIMELIST"
Case Else
debugFMTName = "format=" & ffmt & "?"
End Select
End Function
Function debugProperties(x) As String
' create a string listing all properties of a LCConnection or LCSession
Dim pTok As Long, pTyp As Long, pFlg As Long, pNam As String, more As Boolean, result As String
Dim fProp As LCField
more = x.ListProperty(LCLIST_FIRST, pTok, pTyp, pFlg, pNam)
While more
Set fProp = x.GetProperty(pTok)
result = result & ", " & pNam & "=" & debugstr(fProp, True)
more = x.ListProperty(LCLIST_NEXT, pTok, pTyp, pFlg, pNam)
Wend
debugProperties = Mid$(result, 3)
End Function
Function DebugFieldFlags(Byval flags As Long) As String
Dim result As String
If flags And LCFIELDF_KEY Then
result = ",key"
flags = flags And (Not LCFIELDF_KEY)
End If
If flags And LCFIELDF_KEY_NE Then
result = result & ",!="
flags = flags And (Not LCFIELDF_KEY_NE)
End If
If flags And LCFIELDF_KEY_GT Then
result = result & ",>"
flags = flags And (Not LCFIELDF_KEY_GT)
End If
If flags And LCFIELDF_KEY_LT Then
result = result & ",<"
flags = flags And (Not LCFIELDF_KEY_LT)
End If
If flags And LCFIELDF_NO_NULL Then
result = result & ",nonull"
flags = flags And (Not LCFIELDF_NO_NULL)
End If
If flags And LCFIELDF_TRUNC_PREC Then
result = result & ",truncprec"
flags = flags And (Not LCFIELDF_TRUNC_PREC)
End If
If flags And LCFIELDF_TRUNC_DATA Then
result = result & ",truncdata"
flags = flags And (Not LCFIELDF_TRUNC_DATA)
End If
If flags And LCFIELDF_NO_FETCH Then
result = result & ",nofetch"
flags = flags And (Not LCFIELDF_NO_FETCH)
End If
If flags And LCFIELDF_NO_INSERT Then
result = result & ",noinsert"
flags = flags And (Not LCFIELDF_NO_INSERT)
End If
If flags And LCFIELDF_NO_UPDATE Then
result = result & ",noupdate"
flags = flags And (Not LCFIELDF_NO_UPDATE)
End If
If flags And LCFIELDF_NO_REMOVE Then
result = result & ",noremove"
flags = flags And (Not LCFIELDF_NO_REMOVE)
End If
If flags And LCFIELDF_NO_CREATE Then
result = result & ",nocreate"
flags = flags And (Not LCFIELDF_NO_CREATE)
End If
If flags And LCFIELDF_NO_DROP Then
result = result & ",nodrop"
flags = flags And (Not LCFIELDF_NO_DROP)
End If
If flags > 0 Then
result = result & flags & "?"
End If
If result <> "" Then DebugFieldFlags = "[" & Mid$(result, 2) & "]"
End Function
Sub DebugPrint(Byval s As String)
Dim pos As Long
While Len(s) > 200
pos = Instr(180, s, " ")
If pos = 0 Then
Print s
Exit Sub
Else
Print Left$(s, pos-1)
s = Mid$(s, pos+1)
End If
Wend
If Len(s) > 0 Then
Print s
End If
End Sub
Function debugStrLCField(vel, Byval brief As Boolean) As String
If brief Then
If vel.IsNull(1) Then
debugStrLCField = "NULL"
Elseif vel.Datatype = LCTYPE_BINARY Then
debugStrLCField = "(binary)"
Else
debugStrLCField = debugStr(vel.Value, brief)
End If
Else
If vel.Datatype = LCTYPE_BINARY Then
Dim buf As LCStream
Dim ffmt As Long, fmax As Long, fflg As Long
Call vel.GetFormatStream(fflg, fmax, ffmt)
Set buf = vel.GetStream(1, ffmt)
If ffmt = LCSTREAMFMT_TEXT_LIST Then
debugStrLCField = "F(textlist:" & buf.Text & ")"
Elseif ffmt = LCSTREAMFMT_NUMBER_LIST Then
debugStrLCField = "F(numlist:" & buf.Text & ")"
Elseif ffmt = LCSTREAMFMT_DATETIME_LIST Then
debugStrLCField = "F(datelist:" & buf.Text & ")"
Else
debugStrLCField = "F(binary:" & debugFMTName(ffmt) & ", " & buf.Length & " bytes)"
End If
Else
debugStrLCField = "F" & debugStr(vel.Value, brief)
End If
debugStrLCField = debugStrLCField & DebugFieldFlags(vel.Flags) & DebugFieldVirtCodes(vel)
End If
End Function
Function debugFieldVirtCodes(vel) As String
Dim lngVcode As Long
If vel.ListVirtualCode(LCLIST_FIRST, lngVcode) Then
debugFieldVirtCodes = debugFieldVirtCodes & "," & lngVcode
End If
If debugFieldVirtCodes <> "" Then debugFieldVirtCodes = "[virtcodes=" & Mid$(debugFieldVirtCodes, 2) & "]"
End Function
previous page
|