frmtmpwsda.frm

vb 调用ＩＢＭ ｄｏｍｉｎｏ ｓｅｒｖｅｒ数据库的例子

        tmpRS.Close
        'wdapp.Quit
   Next
   Call GridEX1.Refresh
   
   MsgBox "数据导入成功！"
   Label1.Caption = "导入结束，请继续...."
   
   Exit Sub
'Err3:
 '   MsgBox Err.Description
 '   Resume Next
    
End Sub

Private Sub Form_Load()
Dim C As NotesViewColumn

Dim Mycount As Integer
'''连接到Domino数据库 ,连到省公司文档管理数据库
Set PublicNotesDb = Session.GetDatabase(txtwsdaDominoServer, txtwsdaDominoDatabase) '需要修改 ,前面是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(txtwsdaview) '得到已归档文件的视图

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

''''''''''''''''''''''''''''''''' 从配置文档中取出字段的对应值
Me.List1.Clear
Me.List2.Clear
Dim OldNames() As String
Dim name() As String
'Dim left As String
'Dim right As String

OldNames = Split(txtwsdaZD, ",")
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
''''''''''''''''''''''''''''''''

While i < CInt(txtCount)
   '取出导出标记为空，创建超过2个月的文档
   'If doc.GetFirstItem("TagOfDyp") Is Nothing And DateDiff("m", CDate(doc.Created), CDate(Now)) > 2 Then
  On Error Resume Next
  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("TagOflz") Is Nothing And doc.GetItemValue("docid")(0) <> "" Then
       Call doc.Save(True, True)
       rs.AddNew
       For tmpj = 0 To List1.ListCount - 1
           If List1.List(tmpj) = "成文日期" Or List1.List(tmpj) = "收发日期" Then
              rs.Fields(List1.List(tmpj)) = Left(GetNotNull(doc.GetFirstItem(List2.List(tmpj)).Text), 10)
                    
           Else
              rs.Fields(List1.List(tmpj)) = GetNotNull(doc.GetFirstItem(List2.List(tmpj)).Text)
           End If
'            rs.Fields(List1.List(tmpj)) = Left(GetNotNull(doc.GetFirstItem(List2.List(tmpj)).Text), 10)
'            Dim strVal As String
'            If IsNull(doc.GetItemValue(List2.List(tmpj))(0)) Then
'                strVal = ""
           
           DoEvents
           
            'MsgBox rs.Fields(List1.List(tmpj))
       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
   MsgBox "没有记录"
Else
   rs.MoveFirst
End If
'''''''''添加公文编号和题名到查询条件中
Do While Not rs.EOF
        
        If Not IsNull(rs!文号) Then
          If rs!文号 <> "" Then
          Combo2.AddItem rs!文号
          End If
        End If
        
        If Not IsNull(rs!题名) Then
         If rs!题名 <> "" Then
           Combo4.AddItem rs!题名
          End If
          
        End If
        
        rs.MoveNext
Loop
''''''''''''''''''''''''
Exit Sub
err_main:
    MsgBox "系统连接数据库失败，可能是以下原因：" & _
    Chr(13) & Chr(10) & _
    "1、数据库服务没有启动！" & _
    Chr(13) & Chr(10) & _
    "2、数据库连接参数设置不正确！" & _
    Chr(13) & Chr(10) & _
    "3、网络连接不正确！" & _
    Chr(13) & Chr(10) & _
    Chr(13) & Chr(10) & _
    "请检查无误后重新运行系统。" & _
    Chr(13) & Chr(10) & Chr(13) & Chr(10) & "详细错误信息如下：" & Chr(13) & Chr(10) & "[" & Err.Number & "]" & 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
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 getMaxID()

    Dim rs As New ADODB.Recordset
    rs.Open "select max(ID) as maxid from " & txtwsdaTable, Gcon_main, adOpenDynamic, adLockReadOnly
    MaxID = rs.Fields("maxid")
    Exit Sub
    
End Sub
Private Sub DoDocument(DocFilePath As String, DocumentDocID As String)
       
       Dim wddoc As Word.Document
       Dim pdi As Integer
       Dim pdj As Integer
       Dim AllAdviceNames() As String
       Dim AdviecName As String
       Dim allItem As NotesItem
       Dim strAttDocID As String
       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
       On Error GoTo err1
       Set SourceNotesDb = Session.GetDatabase(txtwsdaDominoServer, DocFilePath)
       If SourceNotesDb Is Nothing Then
           MsgBox ("不能打开Notes库，请查看系统设置！")
       End If
       
     
       Set SourceDoc = SourceNotesDb.GetDocumentByUNID(DocumentDocID)
       If SourceDoc Is Nothing Or SourceDoc = "" Then
       Else
       ''''''''''''''''''''''''''''''''' 根据相应的模版生成相应的word文档
        Set wdapp = New Word.Application
        Me.List3.Clear
       
        Select Case DocFilePath
            Case "fzoa\application\fawen.nsf"
                  AllAdviceNames = Split(strfwgzzd, ",")
                  Set wddoc = wdapp.Documents.Open(App.path & "\发文稿纸.doc")
            Case "fzoa\application\shouwen.nsf"
                  AllAdviceNames = Split(strswgzzd, ",")
                  Set wddoc = wdapp.Documents.Open(App.path & "\收文稿纸.doc")
            Case "fzoa\application\dangweifawen.nsf"
                  AllAdviceNames = Split(strfwgzzd, ",")
                  Set wddoc = wdapp.Documents.Open(App.path & "\发文稿纸.doc")
            Case "fzoa\application\gonghuifawen.nsf"
                  AllAdviceNames = Split(strfwgzzd, ",")
                  Set wddoc = wdapp.Documents.Open(App.path & "\发文稿纸.doc")
            Case "fzoa\application\tuanweifawen.nsf"
                  AllAdviceNames = Split(strfwgzzd, ",")
                  Set wddoc = wdapp.Documents.Open(App.path & "\发文稿纸.doc")
            Case "fzoa\application\xzghfawen.nsf"
                  AllAdviceNames = Split(strfwgzzd, ",")
                  Set wddoc = wdapp.Documents.Open(App.path & "\发文稿纸.doc")
            Case "fzoa\application\huiyijiyao.nsf"
                  AllAdviceNames = Split(strfwgzzd, ",")
                  Set wddoc = wdapp.Documents.Open(App.path & "\发文稿纸.doc")
        End Select

       
        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 SourceDoc.HasItem(List3.List(tmpj)) Then
                 .Bookmarks(List3.List(tmpj)).Select
                 If CStr(SourceDoc.GetFirstItem(List3.List(tmpj)).Text) = "" Then
                    wdapp.Selection.TypeText Text:=" "
                 Else
                    wdapp.Selection.TypeText Text:=CStr(SourceDoc.GetFirstItem(List3.List(tmpj)).Text)
                 End If
              Else
                 wdapp.Selection.TypeText Text:=" "
              End If
            End With
            DoEvents
        Next
        wddoc.SaveAs (txtwsdaYWPath + strTmpYear + SourceDoc.GetItemValue("DocID")(0) + "(yj).doc")  '另存为一个文档
        wddoc.Close
        Set wddoc = Nothing
        wdapp.Quit
       ''''''''''''''''''''''''''''''''''''''''''''''end
      '得到目录表中的最大id
       Call getMaxID

       '''''''''''导出此文件的原文
       strAttDocID = SourceDoc.GetItemValue("AttDocID")(0)
       docRS.Open "select * from " & txtwsdaYW, Gcon_main, adOpenDynamic, adLockOptimistic
       count = 0
       path = txtwsdaYWPath + strTmpYear  '存放附件的路径，到时候你可以修改成你们的路径
       ''''''''''''''''''' 把生成的word文档信息存到sys_link 中
       docRS.AddNew
       docRS.Fields("I_TBLID") = 29
       docRS.Fields("I_RECID") = MaxID
       docRS.Fields("C_NUM") = count
       docRS.Fields("C_EXPLAIN") = "意见"
       docRS.Fields("C_LINK") = txtwsdaYWHttpPath + strTmpYear + SourceDoc.GetItemValue("DocID")(0) + "(yj).doc"
       docRS.Update
       
       '''''''''''''''''''end
       '''''''''''''''''''拆离文档中的附件
       Dim strKZM As String
       
       If strAttDocID <> "" Then
          Set AttView = SourceNotesDb.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") = 29
                 docRS.Fields("I_RECID") = MaxID
                 docRS.Fields("C_NUM") = count + 1
                 docRS.Fields("C_EXPLAIN") = "附件"
                 docRS.Fields("C_LINK") = txtwsdaYWHttpPath + strTmpYear + strAttDocID + "_" + CStr(count) + strKZM
                 docRS.Update
              '''''''''''''''''''''''''''''''''''end
                 count = count + 1
                 DoEvents
              Next
          End If
       End If
     
      ''''''''''''''''''拆离发文中的嵌入式文档，包括红头文件和过程性文件
        Dim strExplain As String
        For Each i In Session.Evaluate("@AttachmentNames", SourceDoc)
            Set AttObjects = SourceDoc.GetAttachment(i)
            If AttObjects Is Nothing Then
            Else
                If InStr(1, AttObjects, "modify") > 0 Then
                    entPath = SourceDoc.GetItemValue("docId")(0) + "(modify)" + Right(AttObjects.Source, 4)
                    Call AttObjects.ExtractFile(path + entPath)
                    strExplain = "过程性文件2"
                ElseIf InStr(1, AttObjects, "draft") > 0 Then
                    entPath = SourceDoc.GetItemValue("docId")(0) + "(draft)" + Right(AttObjects.Source, 4)
                    Call AttObjects.ExtractFile(path + entPath)
                    strExplain = "过程性文件1"
                Else
                    entPath = SourceDoc.GetItemValue("docId")(0) + Right(AttObjects.Source, 4)
                    Call AttObjects.ExtractFile(path + entPath)
                    strExplain = "正文"
                End If
                
                docRS.AddNew
                docRS.Fields("I_TBLID") = 29
                docRS.Fields("I_RECID") = MaxID
                docRS.Fields("C_NUM") = count + 1
                docRS.Fields("C_EXPLAIN") = strExplain
                docRS.Fields("C_LINK") = txtwsdaYWHttpPath + strTmpYear + entPath
                docRS.Update
                count = count + 1
            End If
        Next
      
       '''''''''''''''''''''''''''''''''''''''''''''end
        docRS.Close
        End If
        
        Exit Sub
err1:
        MsgBox Err.Description
        Resume Next
End Sub