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
'-----------------------------------------------------------
'函数名:OpenDoc()
'用  途:用于打开数据库中的word文件
'作  者:张俊
'日  期:2002-07-11
'-----------------------------------------------------------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)
                   
'----------------------------参数说明---------------------------------------------
  'DBConStr:数据库连接字符串;
  'Flow_App_ID:当打开一份文档时,如果没有找到对应的记录,新建时则到模板表中寻找有无
  '             定义好的模板,有则在新建时取出模板。此参数为流程FlowWizardID,通过它来取得
  '             流程文本的模板编号;
  'TableName:因为考虑到出了流程外还有其它应用调用此控件,此值用来表示.DOC文本存取
  '          的数据表;
  'TableID:流程或应用向导所对应的表(肯定为自定义表)ID;
  'FieldName:字段名称;
  'ID:流程调用时候为TableName中的FlowID;
  'typeid:1--非正式文 2--正式文
  'Flag:1 为流程调用;2 为应用向导调用;
  'UserName:为保留笔迹时用到的编辑用户的名称;
'------------------------------------------------------------------------------------------
  
IsReadOnly:   是否为只读进入——目前还为能控制Word不能输入
IsShowRevisions:   是否显示修改的笔迹
IsTrackRevisions:   是否保留修改的笔迹
    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
    
    DBConStr = ""
    DBConStr = "Provider=SQLOLEDB.1;" + eOMPConn.sEOMPConn
    
    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    strSQL = ""
    strSQL = strSQL & "select Content from " & Trim(TableName) & " where FieldName = '"
    strSQL = strSQL & Trim(FieldName) & "' and TableID='" & CStr(TableID) & "'"    iErrFlag = 2
    If Flag = 1 Then
        strSQL = strSQL & " and FlowID='" & CStr(ID) & "'"       '当前进行的是流程调用
        strSQL = strSQL & " and TypeID='" & CStr(typeid) & "'"   '来取正式文或非正式文1--非正式文;2--
    Else
    
        strSQL = strSQL & " and RowID='" & CStr(ID) & "'"        '当前进行的是向导调用
    End If
    
    
    DBConn.ConnectionString = DBConStr
    DBConn.Mode = adModeReadWrite
    DBConn.Open
    DBRS.CursorLocation = adUseClient
    DBRS.Open strSQL, DBConn, adOpenDynamic, adLockBatchOptimistic    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
    
    sFilePath = sFilePath & "\eOMP\"
    sFileName = Trim(CStr(UserID)) & "_" & CStr(Flow_App_ID) & "_" & CStr(ID) + ".doc"
    WordStream.SaveToFile sFilePath & sFileName
    MyWord.Navigate sFilePath & sFileName
lbReturn:
    Form1.Show 1
    WordStream.Close
    Set DBConn = Nothing
    Set DBRS = Nothing
    Set WordStream = Nothing
    
    iErrFlag = 8
    Set WordDoc = MyWord.Document
    Set WordApp = MyWord.Document.Application
    WordDoc.CommandBars("standard").Enabled = True
    WordDoc.CommandBars("standard").Visible = True
    WordDoc.CommandBars("Formatting").Enabled = True
    WordDoc.CommandBars("Formatting").Visible = True
    
    set_CommandBars IsReadOnly
    sUserName = WordApp.UserName
    WordApp.UserName = UserName
    WordDoc.ShowRevisions = IsShowRevisions
    WordDoc.TrackRevisions = IsTrackRevisions
    WordDoc.PrintRevisions = False
   
   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
        
        iProtect = 1
    Else
        'WordDoc.Protect Password:="eOMP", NoReset:=False, Type:=wdAllowOnlyRevisions
        
        iProtect = 0
    End If
    
 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