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