VB实现操作Domino OA接口，操作word

发布时间：2020-12-17 08:16:23 所属栏目：百科来源：网络整理

导读：Option Explicit Dim PublicNotesDb As New Domino.NotesDatabase Dim Session As New Domino.NotesSession Dim view As NotesView Dim MaxID As Long Dim strTitle As String Dim wdapp As Word.Application Public strDominoName As String Public strAllD

Option Explicit
Dim PublicNotesDb As New Domino.NotesDatabase
Dim Session As New Domino.NotesSession
Dim view As NotesView
Dim MaxID As Long
Dim strTitle As String
Dim wdapp As Word.Application
Public strDominoName As String
Public strAllDominoPath As String
Public strDominoType As String
Dim ini As String
Dim WinDir As String
Dim MainTable As String
Dim txtpass As String

Private Sub Command2_Click()
Unload Me

End Sub

Private Sub Command4_Click()
If MsgBox("你确定要导入当前的OA数据吗？请确定是否关闭所有word文档...",vbInformation +

vbOKCancel,"信息") = vbCancel Then Exit Sub

If GridEX1.SelectedItems.Count = 0 Then
MsgBox "先选中要导入的纪录！",vbInformation + vbOKOnly,"信息"
Exit Sub
End If
Dim simTemp As JSSelectedItem
Dim RowData As JSRowData
Dim usql As String
Dim tmpi As Integer
Dim tmpj As Integer
Dim Item As NotesItem
Dim strYWDiskPath As String
Dim strYWHttpPath As String
Dim strYwTable As String
Dim strfwgzzd As String
Dim strswgzzd As String
Dim strxxgzzd As String
Dim strhtgzzd As String
Dim tblid As String
Dim fj As String
'On Error GoTo ErrorHandler
On Error Resume Next

Label1.Caption = "正在导入数据,请等待...."

tblid = GetIDByTblName(MainTable)
strfwgzzd = P_GetProFile("SYSTEM","fwgzzd",ini,WinDir)
strswgzzd = P_GetProFile("SYSTEM","swgzzd",WinDir)
strxxgzzd = P_GetProFile("SYSTEM","xxgzzd",WinDir)
strYwTable = P_GetProFile("SYSTEM","YWTable",WinDir)
strhtgzzd = P_GetProFile("SYSTEM","htgzzd",WinDir)
For tmpi = 1 To GridEX1.RowCount
Set RowData = GridEX1.GetRowData(tmpi)
usql = RowData.value(GridEX1.Columns("ID").Index) & ","
usql = Left(usql,Len(usql) - 1)
Dim rs As New ADODB.Recordset
Dim tmpRs As New ADODB.Recordset
Dim rsoa As New ADODB.Recordset

tmpRs.Open "select * from 临时文书档案一文一件 where ID=" & usql,Gcon_main,

adOpenDynamic,adLockReadOnly
Dim view As NotesView
Set view = PublicNotesDb.GetView("(AllByUNID)")
Dim doc As NotesDocument
Dim dc As NotesDocumentCollection
Dim tmpstr As String
tmpstr = tmpRs.Fields("DOCID")
Set doc = view.GetDocumentByKey(tmpstr,False)
If doc Is Nothing Then
Else
'20051206where rownum<10
rs.Open "select * from " & MainTable & " where id=0",adOpenDynamic,

adLockOptimistic
rs.AddNew
'OA文件对照为备份的数据库表
rsoa.Open " select * from OA文件对照 where id=0",

adLockOptimistic
rsoa.AddNew
For tmpj = 0 To List1.ListCount - 2
rs.Fields(List1.List(tmpj)) = tmpRs.Fields(List1.List(tmpj))
rsoa.Fields(List1.List(tmpj)) = tmpRs.Fields(List1.List(tmpj)) '增加临时库

保证OA数据的完整性
Next

If GetSetting("PDE","DATASET","USERID") = "archive" Then
rs.Fields("全宗号") = "DX01"
End If
rs.Update
rsoa.Update
'处理原文首先是处理意见字段
Me.List3.Clear
Set wdapp = New Word.Application
Dim wddoc As Word.Document
Dim AllAdviceNames() As String
Dim AdviecName As String
Select Case strDominoType
Case "发文"
AllAdviceNames = Split(strfwgzzd,",")
Set wddoc = wdapp.Documents.Open(App.path & "发文稿纸.doc")
strYWDiskPath = P_GetProFile("SYSTEM","fwYWPath",WinDir)
strYWHttpPath = P_GetProFile("SYSTEM","fwXNPath",WinDir)
fj = "附件"
Case "收文"
AllAdviceNames = Split(strswgzzd,")
Set wddoc = wdapp.Documents.Open(App.path & "收文稿纸.doc")
strYWDiskPath = P_GetProFile("SYSTEM","swYWPath","swXNPath",WinDir)
fj = "正文"
Case "信息"
AllAdviceNames = Split(strxxgzzd,")
Set wddoc = wdapp.Documents.Open(App.path & "信息发文稿纸.doc")
strYWDiskPath = P_GetProFile("SYSTEM",WinDir)
fj = "附件"
Case "其它"
AllAdviceNames = Split(strhtgzzd,")
Set wddoc = wdapp.Documents.Open(App.path & "合同审查会签表.doc")
strYWDiskPath = P_GetProFile("SYSTEM",WinDir)
fj = "附件"
End Select
strYWHttpPath = strYWHttpPath & year(Date) & "/"

For tmpj = 0 To UBound(AllAdviceNames)
AdviecName = AllAdviceNames(tmpj)
Me.List3.AddItem AdviecName
DoEvents
Next

'''''''''''''''''''''''''''''''' 更改模版中的标签值
For tmpj = 0 To List3.ListCount - 1
With wddoc
If doc.HasItem(List3.List(tmpj)) Then
.Bookmarks(List3.List(tmpj)).Select
If CStr(doc.GetFirstItem(List3.List(tmpj)).Text) = "" Then
wdapp.Selection.TypeText Text:=" "
Else
wdapp.Selection.TypeText Text:=CStr(doc.GetFirstItem(List3.List

(tmpj)).Text)
End If
Else
wdapp.Selection.TypeText Text:=" "
End If
End With
DoEvents
Next
wddoc.SaveAs (strYWDiskPath + doc.GetItemValue("DocID")(0) + "(yj).doc")

'另存为一个文档
wddoc.Close
Set wddoc = Nothing
wdapp.Quit

''''''''''''''''''''''''''''''''''''''''''''''end

Call getMaxID'得到目录表中的最大id

'''''''''''导出原文
Dim allItem As NotesItem

Dim strAttDocID As String
strAttDocID = doc.GetItemValue("AttDocID")(0)
Dim AttView As NotesView
Dim Attdc As NotesDocumentCollection
Dim Attdoc As NotesDocument
Dim i As Variant
Dim o As Variant
Dim emb As Variant
Dim AttObjects As NotesEmbeddedObject
Dim path As String
Dim entPath As String
Dim Count As Integer
Dim docRS As New ADODB.Recordset
docRS.Open "select * from " & strYwTable & " where id=0",

adOpenDynamic,adLockOptimistic
Count = 0
path = strYWDiskPath '存放附件的路径，到时候你可以修改成你们的路径
''''''''''''''''''' 把生成的word文档信息存到sys_link 中
docRS.AddNew
docRS.Fields("I_TBLID") = tblid
docRS.Fields("I_RECID") = MaxID
docRS.Fields("C_NUM") = Count
docRS.Fields("C_EXPLAIN") = "意见"
docRS.Fields("C_LINK") = strYWHttpPath + doc.GetItemValue("DocID")(0) +

"(yj).doc"
docRS.Update

'''''''''''''''''''end
''''''拆离文档中的附件
Dim strKZM As String
If strAttDocID <> "" Then
Set AttView = PublicNotesDb.GetView("(AttachUnid)")

Set Attdoc = AttView.GetDocumentByKey(strAttDocID)
If Attdoc.HasEmbedded Then
Dim attitem As NotesItem
Set attitem = Attdoc.GetFirstItem("attnames")

For Each i In attitem.Values
Set AttObjects = Attdoc.GetAttachment(i)
If Right(AttObjects.Source,4) = "tiff" Then
strKZM = "." + Right(AttObjects.Source,4)
Else
strKZM = Right(AttObjects.Source,4)
End If
entPath = path + strAttDocID + "_" + CStr(Count) + strKZM
Call AttObjects.ExtractFile(entPath)''''把附件拆到指定的路径下
'''''''往原文表中添加相应的纪录
docRS.AddNew
docRS.Fields("I_TBLID") = tblid
docRS.Fields("I_RECID") = MaxID
docRS.Fields("C_NUM") = Count + 1
docRS.Fields("C_EXPLAIN") = fj '"附件"
docRS.Fields("C_LINK") = strYWHttpPath + strAttDocID + "_" + CStr

(Count) + strKZM

docRS.Update

'''''''''''''''''''''''''''''''''''end
Count = Count + 1

Next
End If
End If

''''''''''''''''''拆离发文中的嵌入式文档，包括红头文件和过程性文件
Dim strExplain As String
For Each i In Session.Evaluate("@AttachmentNames",doc)
Set AttObjects = doc.GetAttachment(i)
If AttObjects Is Nothing Then
Else
If InStr(1,AttObjects,"modify") > 0 Then
entPath = doc.GetItemValue("docId")(0) + "(modify)" + Right

(AttObjects.Source,4)
Call AttObjects.ExtractFile(path + entPath)
strExplain = "过程性文件2"
ElseIf InStr(1,"draft") > 0 Then
entPath = doc.GetItemValue("docId")(0) + "(draft)" + Right

(AttObjects.Source,4)
Call AttObjects.ExtractFile(path + entPath)
strExplain = "过程性文件1"
Else
entPath = doc.GetItemValue("docId")(0) + Right(AttObjects.Source,

4)
Call AttObjects.ExtractFile(path + entPath)
strExplain = "正文"
End If

docRS.AddNew
docRS.Fields("I_TBLID") = tblid
docRS.Fields("I_RECID") = MaxID
docRS.Fields("C_NUM") = Count + 1
docRS.Fields("C_EXPLAIN") = strExplain
docRS.Fields("C_LINK") = strYWHttpPath + entPath '需要修改，改成你们的

相应连接
docRS.Update
End If
Count = Count + 1
Next

'''''''''''''''''''''''''''''''''''''''''''''end
End If'//记录多少条数据被导
'Dim oa As New ADODB.Recordset
'Dim oashuju As Integer
'oa.Open "select count(*) as shuju from 临时文书档案一文一件",adLockReadOnly
'oashuju = oa!shuju
'Gcon_main.Execute "delete from 临时文书档案一文一件 where ID=" & usql

tmpRs.Close
rs.Close
rsoa.Close
docRS.Close
'oa.Close

Set Item = doc.ReplaceItemValue("ISENDARC","1")
Call doc.save(True,True)
Next
Call GridEX1.Refresh

Label1.Caption = "导入数据成功请返回继续"
MsgBox GridEX1.RowCount & "条记录导入成功！"
'Exit Sub

'ErrorHandler:' 错误处理程序。

'MsgBox vbInformation + vbOKOnly,"信息"
'If MsgBox("详细错误信息如下：" & Chr(13) & Chr(10) & "[" & Err.Number & "]" &

"Error0001 错误发生在frmOAGrid：" & Err.Description & Chr(10) & Chr(13) & "你想继续吗？",

vbInformation + vbOKCancel,"信息") = vbCancel Then
' Exit Sub
'Else
'Resume Next
'End If
End Sub

Private Sub Form_Load()
Dim c As NotesViewColumn
Dim pos As Integer
Dim fw As String
Dim Mycount As Integer
ini = "system.ini"
WinDir = P_GetWinDir()
WinDir = App.path & ""
pos = InStrRev(strAllDominoPath,"/")
fw = Right(strAllDominoPath,Len(strAllDominoPath) - pos)
'''连接到Domino数据库
Dim txtDominoServer As String
Dim txtView As String
Dim txtZD As String
On Error GoTo ErrorHandler
'''连接到Domino数据库
Set Session = CreateObject("Lotus.NotesSession")
txtpass = P_GetProFile("SYSTEM","DominoPass",WinDir)
Call Session.Initialize(txtpass) '需要修改
txtDominoServer = P_GetProFile("SYSTEM","DominoServer",WinDir)
MainTable = P_GetProFile("SYSTEM","Maintable",WinDir)
txtView = P_GetProFile("SYSTEM","View",WinDir)
Set PublicNotesDb = Session.GetDatabase(txtDominoServer,strAllDominoPath) '需要修改,前面

是oa服务器的名称(这个需要修改的)。后面是数据库的名称(这个应该不用改，这个路经和你们现在的

路径是一致的)

If PublicNotesDb Is Nothing Then

MsgBox ("不能打开Notes库，请查看系统设置！")

End If
Gcon_main.Execute "Deletefrom 临时文书档案一文一件"'首先删除临时表里面的数据
Dim rs As New ADODB.Recordset
rs.Open "Select * from 临时文书档案一文一件",adLockOptimistic

Dim j As Integer
Set view = PublicNotesDb.GetView(txtView) '得到存放办结文件的试图

Dim doc As NotesDocument
Set doc = view.GetFirstDocument
Dim i As Integer

''''''''''''''''''''''''''''''''' 从配置文档中取出字段的对应值
Select Case strDominoType

Case "收文"
txtZD = P_GetProFile("SYSTEM","swzd",WinDir)
Case "其它"
txtZD = P_GetProFile("SYSTEM","htzd",WinDir)
Case Else
txtZD = P_GetProFile("SYSTEM","fwzd",WinDir)
End Select
Me.List1.Clear
Me.List2.Clear
Dim OldNames() As String
Dim name() As String
OldNames = Split(txtZD,")
Dim tmpj As Integer
For tmpj = 0 To UBound(OldNames)
name = Split(OldNames(tmpj),"=")
Me.List1.AddItem name(1)'list1中存放关系数据库中字段的名称，即=左边的
Me.List2.AddItem name(0)'list1中存放Domino数据库中对应的域名，即=右边的
Next
''''''''''''''''''''''''''''''''
Dim strTmpYear As String
Dim strCount As String
strCount = P_GetProFile("SYSTEM","count",WinDir)

While i < CInt(strCount)
'取出导出标记为空，创建超过2个月的文档
'If doc.GetFirstItem("TagOfDyp") Is Nothing And DateDiff("m",CDate(doc.Created),

CDate(Now)) > 2 Then
If doc Is Nothing Then
i = i + 1
Else

'If doc.GetFirstItem("ISENDARC") Is Nothing And doc.GetItemValue("ISNEEDARC")(0) = "1"

And DateDiff("m",CDate(Now)) > 2 Then
'If doc.GetFirstItem("ISENDARC") Is Nothing And doc.GetItemValue("ISNEEDARC")(0) = "1"

And DateDiff("m",CDate(Now)) > 2 Then
'取出导出标记为空，创建超过2个月的文档改为不要时间的限制陈老师说的20060318
If doc.GetFirstItem("ISENDARC") Is Nothing And doc.GetItemValue("ISNEEDARC")(0) =

"1" Then
rs.AddNew

For tmpj = 0 To List1.ListCount - 1

If List1.List(tmpj) = "成文日期" Then
If doc.HasItem(List2.List(tmpj)) Then
rs.Fields(List1.List(tmpj)) = Left(GetNotNull(doc.GetFirstItem

(List2.List(tmpj)).Text),10)
strTmpYear = Left(GetNotNull(doc.GetFirstItem(List2.List

(tmpj)).Text),4)
End If
ElseIf List1.List(tmpj) = "收发日期" Then
If doc.HasItem(List2.List(tmpj)) Then
rs.Fields(List1.List(tmpj)) = Left(GetNotNull(doc.GetFirstItem

(List2.List(tmpj)).Text),10)
End If
ElseIf List1.List(tmpj) = "登记日期" Then
If doc.HasItem(List2.List(tmpj)) Then
rs.Fields(List1.List(tmpj)) = Left(GetNotNull(doc.GetFirstItem

(List2.List(tmpj)).Text),10)
End If
ElseIf List1.List(tmpj) = "备注" Then
If doc.HasItem(List2.List(tmpj)) Then
rs.Fields(List1.List(tmpj)) = GetNotNull(doc.GetFirstItem

(List2.List(tmpj)).Text) + "(" + strDominoName + ")"
Else
rs.Fields(List1.List(tmpj)) = "(" + strDominoName + ")"
End If
ElseIf List1.List(tmpj) = "年度" Then
rs.Fields(List1.List(tmpj)) = strTmpYear

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'''''''
'20051021 填加
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'''''''
ElseIf List1.List(tmpj) = "责任者" Then
If strDominoType = "发文" Then
Select Case GetSetting("PDE","USERID")
Case "archive"
If fw = "fawen.nsf" Or fw = "xmglfawen.nsf" Then
rs.Fields(List1.List(tmpj)) = "江西省电信有限公司"
Else
If doc.HasItem(List2.List(tmpj)) Then
rs.Fields(List1.List(tmpj)) = "江西省电信有限公司"

& GetNotNull(doc.GetFirstItem(List2.List(tmpj)).Text)
End If
End If
'20051212添加：把全宗号附植为“DXO1”
rs.Fields("全宗号") = "DX01"
Case "archive_nc"
If fw = "fawen.nsf" Then
rs.Fields(List1.List(tmpj)) = "有限公司南昌

市分公司"
Else
If doc.HasItem(List2.List(tmpj)) Then
rs.Fields(List1.List(tmpj)) = "电信有限公司

南分公司" & GetNotNull(doc.GetFirstItem(List2.List(tmpj)).Text)
End If
End If

End Select
Else
If doc.HasItem(List2.List(tmpj)) Then
rs.Fields(List1.List(tmpj)) = GetNotNull(doc.GetFirstItem

(List2.List(tmpj)).Text)
End If
'20051212添加：把全宗号附植为“DXO1”
If GetSetting("PDE","USERID") = "archive" Then
rs.Fields("全宗号") = "DX01"
End If
End If
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'''''''''''''
Else
If doc.HasItem(List2.List(tmpj)) Then
rs.Fields(List1.List(tmpj)) = GetNotNull(doc.GetFirstItem

(List2.List(tmpj)).Text)
End If
End If

Next
rs.Update

i = i + 1
End If
'问题
Set doc = view.GetNextDocument(doc)
DoEvents
End If
Wend

Call ShowGridEX1
If rs.EOF And rs.BOF Then

Else
rs.MoveFirst
End If

Exit Sub
ErrorHandler:' 错误处理程序。

MsgBox "错误发生在-frmOAGrid-Form_Load：" & Chr(13) & Chr(10) & err.Description,

vbInformation + vbOKOnly,"信息"

End Sub
Private Sub ShowGridEX1()
Dim rs As New ADODB.Recordset

rs.Open "Select * from 临时文书档案一文一件",adLockReadOnly
Set GridEX1.ADORecordset = rs
If GridEX1.Columns(GridEX1.Columns.Count).Caption = "ID" Then GridEX1.Columns

(GridEX1.Columns.Count).Width = 0 '隐含ID

End Sub
Private Sub getMaxID()
Dim rs As New ADODB.Recordset
rs.Open "select max(ID) as maxid from " & MainTable,

adLockReadOnly
MaxID = rs.Fields("maxid")
End Sub
Public Function GetNotNull(O_value As Variant,Optional ByVal vtype As Integer = 2) As

Variant
Select Case vtype
Case 1
GetNotNull = IIf(IsNull(O_value),O_value)
Case 2
GetNotNull = IIf(IsNull(O_value),"",O_value)
Case 3
GetNotNull = IIf(IsNull(O_value),Now,O_value)
End Select
End Function

Private Sub Form_Unload(Cancel As Integer)
strDominoName = ""
Me.Hide
End Sub

Private Sub mnuall_Click()
Call ShowGridEX1
End Sub

Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
Dim where_sql As String
Dim tmpRs As New ADODB.Recordset
Select Case Button.Key
Case "tFhjs"
frmTbl_complex_search.gs_frmTbl_complex_search_tbl_name = "文书档案一文一件"
frmTbl_complex_search.Show 1
If frmTbl_complex_search.sqlstr <> "" Then
where_sql = " Where " & frmTbl_complex_search.sqlstr
'Call refresh_grid
tmpRs.Open "select * from 临时文书档案一文一件 " + where_sql,adLockOptimistic
Set GridEX1.ADORecordset = tmpRs
If GridEX1.Columns(GridEX1.Columns.Count).Caption = "ID" Then GridEX1.Columns

(GridEX1.Columns.Count).Width = 0 '隐含ID
End If
Case "ShowAll"
Call ShowGridEX1
Case "tSend"
Call Command4_Click
Case "tClose"
Unload Me
End Select
End Sub

if Node.HasChildren then Node.ImageIndex:=0 else Node.ImageIndex:=2; if Node.Expanded then Node.ImageIndex:=1;

（编辑：李大同）

【声明】本站内容均来自网络，其相关言论仅代表作者个人观点，不代表本站立场。若无意侵犯到您的权利，请及时与联系站长删除相关内容!