clsf1file.cls

财务信息管理系统,适合做毕业论文的人使用

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsF1File"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private m_sErr As String            '出错信息
Private m_bNoErrMessage As Boolean  '无错误提示

'连接数据源
Private Function OpenConnection(Cn As ADODB.Connection, sDataSourceName$) As Boolean
    On Error GoTo Err_OpenConnection
    OpenConnection = False
    
    m_sErr = "数据源连接串‘" & sDataSourceName$ & "’语法错误"
    Cn.ConnectionString = sDataSourceName$
    
    m_sErr = "数据源‘" & sDataSourceName$ & "’连接失败"
    Cn.Open
    
    OpenConnection = True
    
Err_OpenConnection:
End Function

'文件导入
Public Function F1Import(sDataSourceName$, sImportFile$, Optional iID& = 1) As Boolean
    Dim Rs As New ADODB.Recordset
    Dim Cn As New ADODB.Connection
    
    Dim iFree As Long
    Dim iLen As Long
    
    Dim FileArray() As Byte
    
    On Error GoTo Err_F1Import
    F1Import = False
    
    m_sErr = "文件‘" & sImportFile$ & "’无法访问"
    iLen = FileLen(sImportFile$)
    
    m_sErr = "文件‘" & sImportFile$ & "’太大"
    ReDim FileArray(iLen)
    
    '从文件中读取数据
    m_sErr = "文件‘" & sImportFile$ & "’无法打开"
    iFree = FreeFile
    Open sImportFile$ For Binary As #iFree
    
    m_sErr = "文件‘" & sImportFile$ & "’不能读取"
    Get #iFree, , FileArray
    Close #iFree
    
    '导入数据库
    If Not OpenConnection(Cn, sDataSourceName$) Then GoTo Err_F1Import
    
    m_sErr = "无法打开数据表"
    Rs.Open "Select * From FD_F1File Where f1file_id = " & iID&, Cn, adOpenDynamic, adLockOptimistic
    With Rs
        If .EOF Or .BOF Then
           m_sErr = "无法向数据表中添加 f1file_id =" & iID& & " 的记录"
           .AddNew
           .Fields("f1file_id").Value = iID&
        End If
    
        m_sErr = "无法向数据表导入数据"
        .Fields("contents").AppendChunk FileArray
        .Fields("size_num").Value = iLen
        .Update
    End With
    
    F1Import = True
    m_sErr = vbNullString
    
Err_F1Import:
    On Error Resume Next
    CloseObject Rs
    CloseObject Cn
    If Not m_sErr = vbNullString Then ShowErrMessage m_sErr
End Function


'文件导出
Public Function F1Export(sDataSourceName$, sExportFile$, Optional iID& = 1) As Boolean
    Dim Rs As New ADODB.Recordset
    Dim Cn As New ADODB.Connection
    
    Dim iFree As Long
    Dim iLen As Long
    
    Dim FileArray() As Byte
    
    Dim VtsFilePath As String
    
    On Error GoTo Err_F1Export
    
    F1Export = False
    VtsFilePath = App.Path & "\Res\" & g_conF1FileName
    
    If Not OpenConnection(Cn, sDataSourceName$) Then GoTo Err_F1Export
    
    m_sErr = "无法打开数据表"
    Rs.Open "Select * From FD_F1File Where f1file_id = " & iID&, Cn
    
    With Rs
        If .EOF Or .BOF Then
            F1Import g_sDataSourceName, VtsFilePath
            GoTo Err_F1Export
        End If
    End With
    
    With Rs
        m_sErr = "数据表中没有 f1file_id =" & iID& & " 的记录"
        If .EOF Or .BOF Then GoTo Err_F1Export
        
        m_sErr = "数据表中的记录无效"
        If IsNull(.Fields("size_num").Value) Then GoTo Err_F1Export
        If IsNull(.Fields("contents").Value) Then GoTo Err_F1Export
        
        '从数据库中读取数据
        iLen = .Fields("size_num").Value
        
        m_sErr = "文件过大"
        ReDim FileArray(iLen)
        
        m_sErr = "无法读取数据"
        FileArray = Rs.Fields("contents").GetChunk(iLen)
        
        '输出文件
        If Not Dir(sExportFile$) = vbNullString Then
           m_sErr = "目标文件写保护"
           Kill sExportFile$
        End If
        
        m_sErr = "无法打开目标文件"
        iFree = FreeFile
        Open sExportFile$ For Binary As #iFree
        
        m_sErr = "无法写入目标文件"
        Put #iFree, , FileArray
        Close #iFree
    
    End With
    F1Export = True
    m_sErr = vbNullString
    
Err_F1Export:
    On Error Resume Next
    CloseObject Rs
    CloseObject Cn
    If Not m_sErr = vbNullString Then ShowErrMessage m_sErr
End Function

'显示错误信息
Private Sub ShowErrMessage(sMessage As String)
    If Not m_bNoErrMessage Then
       MsgBox sMessage, vbOKOnly + vbCritical
    End If
End Sub

'出错后免提示
'缺省：否
Public Property Get NoErrMessage() As Boolean
    NoErrMessage = m_bNoErrMessage
End Property
Public Property Let NoErrMessage(bNewValue As Boolean)
    m_bNoErrMessage = bNewValue
End Property

'错误信息
Public Property Get ErrDescription() As String
    ErrDescription = m_sErr
End Property
Public Property Let ErrDescription(sNewErr As String)
    m_sErr = sNewErr
End Property

Private Sub CloseObject(oObject As Object)
    On Error Resume Next
    oObject.Close
End Sub