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

为什么80%的码农都做不了架构师？>>>   

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", ini, WinDir)
   strxxgzzd = P_GetProFile("SYSTEM", "xxgzzd", ini, WinDir)
   strYwTable = P_GetProFile("SYSTEM", "YWTable", ini, WinDir)
   strhtgzzd = P_GetProFile("SYSTEM", "htgzzd", ini, 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", Gcon_main, adOpenDynamic,

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

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", ini, WinDir)
                     strYWHttpPath = P_GetProFile("SYSTEM", "fwXNPath", ini, WinDir)
                     fj = "附件"
               Case "收文"
                     AllAdviceNames = Split(strswgzzd, ",")
                     Set wddoc = wdapp.Documents.Open(App.path & "\收文稿纸.doc")
                     strYWDiskPath = P_GetProFile("SYSTEM", "swYWPath", ini, WinDir)
                     strYWHttpPath = P_GetProFile("SYSTEM", "swXNPath", ini, WinDir)
                     fj = "正文"
                Case "信息"
                     AllAdviceNames = Split(strxxgzzd, ",")
                     Set wddoc = wdapp.Documents.Open(App.path & "\信息发文稿纸.doc")
                     strYWDiskPath = P_GetProFile("SYSTEM", "fwYWPath", ini, WinDir)
                     strYWHttpPath = P_GetProFile("SYSTEM", "fwXNPath", ini, WinDir)
                      fj = "附件"
                Case "其它"
                     AllAdviceNames = Split(strhtgzzd, ",")
                     Set wddoc = wdapp.Documents.Open(App.path & "\合同审查会签表.doc")
                     strYWDiskPath = P_GetProFile("SYSTEM", "fwYWPath", ini, WinDir)
                     strYWHttpPath = P_GetProFile("SYSTEM", "fwXNPath", ini, 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", Gcon_main,

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, AttObjects, "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 临时文书档案一文一件", Gcon_main,

adOpenDynamic, 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", ini, WinDir)
Call Session.Initialize(txtpass) '需要修改
txtDominoServer = P_GetProFile("SYSTEM", "DominoServer", ini, WinDir)
MainTable = P_GetProFile("SYSTEM", "Maintable", ini, WinDir)
txtView = P_GetProFile("SYSTEM", "View", ini, WinDir)
Set PublicNotesDb = Session.GetDatabase(txtDominoServer, strAllDominoPath) '需要修改 ,前面

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

路径是一致的)

If PublicNotesDb Is Nothing Then

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

End If
Gcon_main.Execute "Delete  from 临时文书档案一文一件"  '首先删除临时表里面的数据
Dim rs As New ADODB.Recordset
rs.Open "Select * from 临时文书档案一文一件", Gcon_main, adOpenDynamic, 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", ini, WinDir)
    Case "其它"
        txtZD = P_GetProFile("SYSTEM", "htzd", ini, WinDir)
    Case Else
         txtZD = P_GetProFile("SYSTEM", "fwzd", ini, 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", ini, 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(doc.Created), CDate(Now)) > 2 Then
    'If doc.GetFirstItem("ISENDARC") Is Nothing And doc.GetItemValue("ISNEEDARC")(0) = "1"

And DateDiff("m", CDate(doc.Created), 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", "DATASET", "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", "DATASET", "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 临时文书档案一文一件", Gcon_main, adOpenDynamic, 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, Gcon_main, adOpenDynamic,

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), 0, 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, Gcon_main,

adOpenDynamic, 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;

转载于:https://my.oschina.net/mellen/blog/124888