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

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