Dim strSQL As String
Dim pisReadOnly As Boolean
Dim DBConn As ADODB.Connection
Dim DBRS As ADODB.Recordset
Dim WordStream As ADODB.Stream
Dim FileSys As New FileSystemObject
Dim WordApp As New Word.Application
Dim WordDoc As New Word.Document
Dim eOMPConn As New eOMPDll.eOMPClsDll
Dim sFileName As String
Dim sUserName As String
Dim sFilePath As String
Public Sub OpenDoc(ByVal DbConStr As String, _
ByVal Flow_App_ID As Integer, _
ByVal TableName As String, _
ByVal TableID As Integer, _
ByVal FieldName As String, _
ByVal ID As Integer, _
ByVal TypeID As Integer, _
ByVal Flag As Integer, _
ByVal UserID As Integer, _
ByVal UserName As String, _
ByVal isReadOnly As Boolean, _
ByVal IsShowRevisions As Boolean, _
ByVal IsTrackRevisions As Boolean, _
ByVal sPath As String)
Dim iErrFlag As Integer
Dim iFlag As Integer
Dim iProtect As Integer
On Error GoTo lbError
If Trim(eOMPConn.sEOMPConn) = "" Then
MsgBox "对不起,请检查你的机器是否安装了信使并运行至少一次!"
Exit Sub
End If
iErrFlag = 1
If FileSys.FolderExists(Environ("windir") + "\Temp\eOMP") Then
FileSys.DeleteFolder (Environ("windir") + "\Temp\eOMP")
End If
lbContinue:
pisReadOnly = isReadOnly
Set DBConn = New ADODB.Connection
Set DBRS = New ADODB.Recordset
Set WordStream = New ADODB.Stream
WordStream.Type = adTypeBinary
iErrFlag = 3
If DBRS.RecordCount > 0 Then '表示非新增记录时调用
WordStream.Open
WordStream.Write DBRS.Fields("Content").Value
Else '寻找模板表.如果没有找到相对应的用户定制模板,则付空白模板
DBRS.Close
strSQL = ""
strSQL = strSQL & "select * from T_Flow_App_TemplateList with(NoLock) "
strSQL = strSQL & " where TypeID='" & CStr(Flag) & "' and Flow_App_ID='"
strSQL = strSQL & CStr(Flow_App_ID) & "' and IsCustomize=0"
DBRS.CursorLocation = adUseClient
DBRS.Open strSQL, DBConn, adOpenDynamic, adLockBatchOptimistic
If DBRS.RecordCount > 0 Then '表示找到用户定制模板
WordStream.Open
WordStream.Write DBRS.Fields("TempLateContent").Value
Else '打开空白模板
DBRS.Close
strSQL = ""
strSQL = "select * from T_Flow_App_TemplateList where Flow_APP_ID=0 and TypeID=0"
DBRS.CursorLocation = adUseClient
DBRS.Open strSQL, DBConn, adOpenDynamic, adLockBatchOptimistic
If DBRS.RecordCount > 0 Then
WordStream.Open
WordStream.Write DBRS.Fields("TempLateContent").Value
Else
MsgBox "初始化数据库时候忘记了加入初始化空白模板,请和程序员联系!", vbOKOnly, "eOMP提示" '此错误不会发生
Exit Sub
End If
End If
End If
iErrFlag = 4
If FileSys.FolderExists(sFilePath & "\eOMP") = False Then
FileSys.CreateFolder (sFilePath & "\eOMP")
End If
If WordDoc.TrackRevisions = True Then
'MsgBox "1"
WordApp.Documents.Item(1).Protect Password:="eOMP", NoReset:=False, Type:=wdAllowOnlyRevisions
Else
'MsgBox "0"
If isReadOnly = True Then
WordApp.Documents.Item(1).Protect Password:="eOMP", NoReset:=False, Type:=wdAllowOnlyFormFields
End If
End If
If isReadOnly = True Then
'WordDoc.Protect Password:="eOMP", NoReset:=False, Type:=wdAllowOnlyFormFields
iErrFlag = 9
If FileSys.FileExists(Environ("windir") & "\Temp\Blank.doc") = False Then
Set WordStream = New ADODB.Stream
WordStream.Type = adTypeBinary
WordStream.Open
WordStream.SaveToFile Environ("windir") & "\Temp\Blank.doc"
WordStream.Close
End If
Exit Sub
lbError:
If iErrFlag = 8 Then
GoTo lbReturn
End If
If iErrFlag = 1 Then
GoTo lbContinue
Exit Sub
End If
MsgBox iErrFlag
MsgBox "由于以下原因,打开文档出错!" + Err.Description, vbOKOnly, "eOMP提示"
End Sub