数据库信息摘要 转化作xml文件

Option Public
Option Explicit
Option Compare Nocase

Const lngMaxLength=32000
Const strReturn=|
|

Const cstForReading =&H8000
Const cstForWriting =&H8001
Const cstForAppending =&H8002

Const cstBinnary =&H8101
Const cstUnicode =&H8102

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Const errUndefinedCode=&H1214
Const errUndefinedMsg="Undefined error "

Const errFileExistingCode=&H1001
Const errFileExistingMsg ="The File Has been there."

Const errFileNoneCode =&H1002
Const errFileNoneMsg ="File Not Found"

Const errFileHandleWrongModeCode=&H1004
Const errFileHandleWrongModeMsg="Wrong mode on handling the file "

Const errNotAArrayCode=&H1011
Const errNotAArrayMsg="Not A Array Data"

Const errIsNullCode=&H1012
Const errIsNullMsg="The variant is a null."

Const errIsEmptyStringCode=&H1013
Const errIsEmptyStringMsg="The string contains no characters in it."


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Bug良多，编写时候太急促，不到十个小时，没有按照层次来好好管理。
' 很多的功能也没有测试完。也无心去完善，现在唯一能做的就是加上对代码的释义
' 如果以后有人能帮忙完善。不胜感激！如果再能发给我完善的结果，那更是感恩泪涕：OnceATime@163.com
'
' LS的局限性，在这里表现的还是很明显的。如果留意观察，会发现我曾经绕的很麻烦。
' 错误的处理，其实这里已经有了很好的开始，或者说仅仅的一个思路，一个框架。
' 因为当时匆忙，肯定是没有多的时间放这里的了。
' LS的错误处理，其实未必比java的try机制弱到哪里去。我所讨厌的，仅仅是goto语句
'
' 中国的程序员，始终是在生存线上挣扎的
' 编程的快乐，，，，，，，在我有生之年只怕是没有希望了。
'
'
'                              FangZeYu（OnceATime@163.com）
'                                           2003-11-10
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''





Public Class FileSystemObject
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' 模拟FileSystemObject类，主要功能处理文件目录
' 现已实现功能，OpenTextFile、CreateTextFile，产生一个TextFileStream对象
' 文件读写数据流（未完全测试）
' 其它功能待开发
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Sub New()

End Sub

Public Function CreateTextFile(strFileName As String,bolOverwrite As Integer)
On Error Goto error_handle
If (Dir(strFileName)<>"") Then
If bolOverwrite Then
Kill strFileName
Else
Set CreateTextFile=Nothing
Error errFileExistingCode , errFileExistingMsg
Exit Function
End If
End If
Dim intNum As Integer
Dim vRet As New FileTextStream
If vRet.OpenTextFile(strFileName,cstForWriting)=False Then
Error errUndefinedCode , errUndefinedMsg
End If
Set CreateTextFile=vRet

Exit Function
error_handle:
Set CreateTextFile=Nothing
Exit Function
End Function

Public Function OpenTextFile(strFileName As String,bolAutoCreate As Integer , lngMode As Long)
On Error Goto error_handle
If (Dir(strFileName)="") Then
If bolAutoCreate Then
Else
Set OpenTextFile=Nothing
Error errFileNoneCode , errFileNoneMsg
Exit Function
End If
End If
Dim vRet As New FileTextStream
If vRet.OpenTextFile(strFileName,lngMode)=False Then
Error errUndefinedCode , errUndefinedMsg
End If

Exit Function
error_handle:
Set OpenTextFile=Nothing
Exit Function
End Function
End Class

Public Class FileTextStream
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' 文件读写数据流，模拟FileStream功能
' 基本上具备了文件读写绝大部分的操作，WriteString、WriteLn、ReadString、ReadLn（该功能似乎有问题）、
' ReadAll、OpenTextFile（实际上也可以新建文件）、
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private mFileNumber As Integer
Private mFileName As String
Private mSeek As Long
Private mMode As Long

Public Sub New()

End Sub

Public Sub Close()
Close # mFileNumber
End Sub

Public Property Get FileName As String
FileName=mFileName
End Property

Public Function WriteString(strValue As String)
On Error Goto error_handle 
If mMode<>cstForWriting Then
Me.close
If Me.OpenTextFile(Me.FileName,cstForWriting) =False Then
Error errUndefinedCode , errUndefinedMsg
End If
End If
Print # mFileNumber , strValue
WriteString=True

Exit Function 
error_handle:
WriteString=False
Exit Function
End Function

Public Function Writeln(strValue As String)
On Error Goto error_handle 
If mMode<>cstForWriting Then
Me.close
If Me.OpenTextFile(mFileName,cstForWriting) =False Then
Error errUndefinedCode , errUndefinedMsg
End If
End If
Print # mFileNumber , strValue
Writeln=True

Exit Function 
error_handle:
Writeln=False
Exit Function
End Function

Public Function Readln()
On Error Goto error_handle 
If mMode<>cstForReading Then
Me.close
If Me.OpenTextFile(Me.FileName,cstForReading) =False Then
Error errUndefinedCode , errUndefinedMsg
End If
End If
Dim strRet As String
Line Input # mFileNumber,strRet
Readln=strRet

Exit Function 
error_handle:
Readln=Null
Exit Function
End Function

Public Function FileEnd() As Long
If Eof(mFileNumber) Then
FileEnd=True
Else
FileEnd=False
End If
End Function

Public Function ReadAll()
On Error Goto error_handle 
If mMode<>cstForReading Then
Me.close
If Me.OpenTextFile(Me.FileName,cstForReading) =False Then
Error errUndefinedCode , errUndefinedMsg
End If
End If
Dim strRet As String
Dim lngFileLen As Long,lngTail As Long,lngPages As Long
Dim i As Long,str1 As String,tSeek As Long
lngFileLen=Lof(mFileNumber)
lngPages=Fix((lngFileLen-1) / lngMaxLength)+1
lngTail=lngFileLen Mod lngMaxLength
tSeek=Seek(mFileNumber)
Seek #mFileNumber ,1 
For i=1 To lngPages-1
str1=Input(lngMaxLength,#mFileNumber)
strRet=strRet+str1
Next
str1=Input(lngTail,#mFileNumber)
strRet=strRet+str1
Seek #mFileNumber ,tSeek
ReadAll=strRet

Exit Function 
error_handle:
ReadAll=Null
Exit Function
End Function

Public Function ReadString(lngLength)
On Error Goto error_handle 
If mMode<>cstForReading Then
Me.close
If Me.OpenTextFile(Me.FileName,cstForReading) =False Then
Error errUndefinedCode , errUndefinedMsg
End If
End If
Dim strRet As String
strRet=Input(lngLength,#mFileNumber)
ReadString=strRet

Exit Function 
error_handle:
ReadString=Null
Exit Function
End Function

Public Function OpenTextFile(strFileName As String,lngMode As Long) As Long
On Error Resume Next 
Close # mFileNumber
On Error Goto error_handle
If (Dir(strFileName)="" And lngMode=cstForReading) Then
Error errFileNoneCode , errFileNoneMsg
End If
Dim intNum As Integer
Dim vRet As FileTextStream
intNum=Freefile()
If lngMode=cstForReading Then
Open strFileName For Input As # intNum
mMode=cstForReading
Elseif lngMode=cstForWriting Then
Open strFileName For Output As # intNum
mMode=cstForWriting
Else
Error errFileHandleWrongModeCode,errFileHandleWrongModeMsg
End If
mFileNumber=intNum
mFileName=strFileName
OpenTextFile=True

Exit Function
error_handle:
OpenTextFile=False
Exit Function
End Function

Sub Delete()
Me.close
End Sub

End Class

Type FieldNameTitle
Name As String
Title As String
End Type

Public Class DatabaseUsing
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' 这个不是一个真正意义上完全抽象的类，因为编写它的时候，有着太急切近利的目的。
'
' 数据库内部查询，将结果输出到一个xml文件中，查询主要针对附件文件
' 已实现功能，针对数据库或者视图检索
'
' 调用范例代码：
' dim xDatabaseUsing as new DatabaseUsing '产生一个应用对象
' xDatabseUsing.AddFieldNameTitleSimple("Subject","主题") '添加一个跟踪域subject，查询的结果在xml中以“主题”这样的tagName出现
' dim dbSearch as new NotesDatabase("","help/help_designer5.nsf") '需要检索的数据库对象
' xDatabaseUsing.MakeResult(dbSearch,"c:/123.xml","") '查询数据库（如果第三个参数ViewName不设置为空，则检索该视图）
'
' tStm：内部的一个文件读写器，因为它不是一个member数据，所以以temp（或variant）标识
' mFieldNameTitles：数组，与mFieldNameTitlesCount联合，表示在数据抓取时候，需要额外添加的域。
' 数组每个成员包含两个内容：FieldName，域的名称；FiledTitle，域的表现名称
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private tStm As FileTextStream 'the working stream object
Private mFieldNameTitles(100) As FieldNameTitle
Private mFieldNameTitlesCount As Integer

Public Sub New
Set tStm=New FileTextStream
End Sub

Public Function AddFieldNameTitle(fFieldNameTitle As FieldNameTitle)
On Error Goto error_handle
If Isnull(fFieldNameTitle.Name) Or Isnull(fFieldNameTitle.Title) Then
Error errIsNullCode , errIsNullMsg
End If
If Trim(fFieldNameTitle.Name)="" Or Trim(fFieldNameTitle.Title)="" Then
Error errIsEmptyStringCode , errIsEmptyStringMsg
End If
mFieldNameTitles(mFieldNameTitlesCount)=fFieldNameTitle
mFieldNameTitlesCount=mFieldNameTitlesCount+1
If (mFieldNameTitlesCount Mod 100 = 0) Then
' Redim Preserve mFieldNameTitles(100+mFieldNameTitlesCount)
End If
AddFieldNameTitle=True
Exit Function
error_handle:
Print Error
AddFieldNameTitle=False
Exit Function
End Function

Public Function AddFieldNameTitleSimple(fName As String, fTitle As String)
Dim xFieldNameTitle As FieldNameTitle
xFieldNameTitle.Name=fName
xFieldNameTitle.Title=fTitle
AddFieldNameTitleSimple=AddFieldNameTitle(xFieldNameTitle)
End Function

Public Function ClearFiledNameTitles()
mFieldNameTitlesCount=0
End Function

Public Property Get FieldNameTitles
' FieldNameTitles=mFieldNameTitles
End Property

Public Function MakeResult(DB As NotesDatabase,strFileName As String ,strViewName As String)
On Error Goto error_handle
Call tSTM.OpenTextFile(strFileName,cstForWriting)
tSTM.Writeln(XMLHead)
tSTM.Writeln("<数据库>")
If strViewName ="" Then
LoopDB DB 
Else
Dim tView As NotesView
Set tView=db.GetView(strViewName)
If Not (tView Is Nothing ) Then LoopView tView
End If
tSTM.Writeln("</数据库>")
tSTM.close
MakeResult=True

Exit Function
error_handle:
MakeResult=False
Exit Function
End Function 

Private Function XMLSimpleNode(strNodeName As String,strNodeValue As String)
XMLSimpleNode="<"+strNodeName+">"+CheckString(strNodeValue)+"</"+strNodeName+">"
End Function

Private Function CheckString(fString)As String
'为处理xml中，不合格的字符，但是实际上的需要处理的不仅仅是&，应该留到后面的地方来作一次性的处理
Dim pos1 As Integer
pos1=Instr(fString,"&")
If pos1=0 Then
CheckString=fString
Exit Function
End If
Dim str1 As String
str1=Mid(fString,1,pos1-1)+Mid(fString,pos1+1)
CheckString=CheckString(str1)
End Function

Private Function XMLHead As String
XMLHead=|<?xml version="1.0" encoding="GBK"?>
<!--Coded By FangZeYu(OnceATime@163.com) 2003.11.06-->|
End Function

Private Function LoopDB (fDB As NotesDatabase) As Integer
On Error Goto error_handle
Dim intRet As Integer

Dim tDocs As NotesDocumentCollection
Dim tDoc As NotesDocument
Dim lngDocs As Long ,lngPos As Long
Set tDocs=fDB.AllDocuments
lngDocs=tDocs.count
If lngDocs=0 Then
Print "Empty documentcollection  ......"
Error 1,""
End If

Set tDoc=tDocs.GetFirstDocument
While Not tDoc Is Nothing
lngPos=lngPos+1
Print "  Checking  on document " & lngPos & " / "& lngDocs
tSTM.Writeln("<文档 id="""+tDoc.UniversalID+""">")
LoopDoc tDoc
tSTM.writeln("</文档>")
Set tDoc=tDocs.GetNextDocument(tDoc)
Wend
LoopDB=True

Exit Function
error_handle:
LoopDB=False
Exit Function
End Function

Private Function LoopView(fView As NotesView) As Integer
On Error Goto error_handle

Dim tDoc As NotesDocument
Dim lngDocs As Long ,lngPos As Long
lngDocs=fView.AllEntries.count
If lngDocs=0 Then
Print "Empty documentcollection  ......"
Error 1,""
End If

Set tDoc=fView.GetFirstDocument
While Not tDoc Is Nothing
lngPos=lngPos+1
Print "  Checking  on document " & lngPos & " / "& lngDocs
tSTM.Writeln("<文档 id="""+tDoc.UniversalID+""">")
LoopDoc tDoc
tSTM.writeln("</文档>")
Set tDoc=fView.GetNextDocument(tDoc)
Wend
LoopView=True

Exit Function
error_handle:
LoopView=False
Exit Function
End Function

Private Function LoopDoc(fDoc As NotesDocument) As Integer
Dim strAttItemName As String , strAttItemValue As String,datAttItemLastModified
Dim tItems
Dim strUNID As String
Dim item1
strAttItemName="$FILE"

strUNID=Cstr(fDoc.UniversalID)
Dim i As Integer

For i=0 To mFieldNameTitlesCount-1
Set item1=fDoc.GetFirstItem(mFieldNameTitles(i).Name)
If Not (item1 Is Nothing) Then
tSTM.Writeln(XMLSimpleNode(mFieldNameTitles(i).Title,item1.values(0)))
Else
tSTM.Writeln(XMLSimpleNode(mFieldNameTitles(i).Title,""))
End If
Next
tItems=fDoc.Items
Forall tItem In tItems
If tItem.name=strAttItemName Then
'working on the attachs/oleobject
strAttItemValue=tItem.values(0)
datAttItemLastModified=tItem.LastModified
tSTM.Writeln("<附件>")
' tSTM.Writeln(XMLSimpleNode("name",strAttItemName))
tSTM.Writeln(XMLSimpleNode("名称",strAttitemValue))
tSTM.Writeln(XMLSimpleNode("上传时间",Cstr(datAttItemLastModified)))
tSTM.Writeln("</附件>")
End If
End Forall
End Function
End Class




''''''''''''''''''''''''测试XMLUsing1.equalto.8u8.com 库
Option Public
Use "XMLUsing1.equalto.8u8.com"

Sub Initialize

Dim dbUsing As New DatabaseUsing
Dim session As New NotesSession
Dim db As NotesDatabase
Set db=New NotesDatabase(session.CurrentDatabase.Server,"cmccoa\swgl.nsf")
Dim xFieldNameTitle As FieldNameTitle
xFieldNameTitle.Name="TxLwdw"
xFieldNameTitle.Title="来文单位"
' dbUsing.AddFieldNameTitle xFieldNameTitle
dbUsing.AddFieldNameTitleSimple "TxLwdw","来文单位"
dbUsing.AddFieldNameTitleSimple "Subject","主题词"
Call dbUsing.MakeResult(db,"c:\123.xml","vwall")

End Sub