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
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
解决方案 »
免费领取超大流量手机卡,每月29元包185G流量+100分钟通话, 中国电信官方发货