clscompress.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 = "clsCompress"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'***************************************************************************
'描述：  完成数据的压缩、解压缩功能。
'被调用：
'调用：
'函数及过程：1   Compress                 压缩文件
'           2   UnCompress               解压缩文件
'***************************************************************************

Option Explicit

Private msPath As String                                ''' 要压缩的目录，或解压到的目录
Private msFilename As String                            ''' 要压缩或解压缩的文件名
Private mdblFileSize As Long                            ''' 生成的压缩文件大小 0 - 一个文件，否则为对应大小的文件
Private miCompressType As Integer                       ''' 压缩的方式
Private msArjPath As String                             ''' arj程序路径

''' 路径
Public Property Get CompressPath() As String
    CompressPath = msPath
End Property

Public Property Let CompressPath(ByVal vNewValue As String)
    msPath = vNewValue
End Property

''' 压缩文件名
Public Property Get FileName() As String
    FileName = msFilename
End Property

Public Property Let FileName(ByVal vNewValue As String)
    msFilename = vNewValue
End Property

''' 压缩的文件大小
Public Property Get FileSize() As Double
    FileSize = mdblFileSize
End Property

Public Property Let FileSize(ByVal vNewValue As Double)
    mdblFileSize = vNewValue
End Property

''' 压缩方式
Public Property Get CompressType() As Integer
    CompressType = miCompressType
End Property

Public Property Let CompressType(ByVal vNewValue As Integer)
    miCompressType = vNewValue
End Property

'=======================================================================
'描 述：将指定目录的文件生成压缩文件。
'输 入：无
'输 出：True - 成功；False - 失败；
'调用关系：被调用 -外部函数
'         调  用 -无
'========================================================================


Public Function Compress() As Boolean
On Error GoTo err
    Dim sPath As String                                 ''' 要压缩的目录
    Dim sZipFile As String                              ''' 压缩成的文件名
    Dim sCommand As String                              ''' 命令语句
    
    Compress = False
    ''' 要压缩的目录
    sPath = msPath
    GetStdName sPath
    
    ''' 压缩成的文件名
    sZipFile = msFilename
    GetStdName sZipFile
    
    sCommand = msArjPath & " a " & sZipFile & " " & sPath & " -r -y "
    
    If mdblFileSize <> 0 Then
        sCommand = sCommand & " -ve" & CStr(mdblFileSize) & "k "
    End If
    
    ''' 执行压缩过程
    If SyncShell(sCommand, , , True) = False Then Exit Function
    
    mdblFileSize = 0
    Compress = True
    Exit Function
err:

End Function

'=======================================================================
'描 述：将压缩文件在指定目录下解压缩。
'输 入：无
'输 出：True - 成功；False - 失败；
'调用关系：被调用 -外部函数
'         调  用 -无
'========================================================================

Public Function UnCompress() As Boolean
    Dim sPath As String                                 ''' 要压缩的目录
    Dim sZipFile As String                              ''' 压缩成的文件名
    Dim sCommand As String                              ''' 命令语句
    
    
    ''' 解压缩的目录
    sPath = msPath
    GetStdName sPath
    
    ''' 压缩成的文件名
    sZipFile = msFilename
    GetStdName sZipFile
    
    sCommand = msArjPath & " x " & sZipFile & " " & sPath & " -r -y -v "

    SyncShell sCommand

End Function

'=======================================================================
'描 述：处理路径和文件名中的空格
'输 入：vsPath - 路径或文件名
'输 出：无
'调用关系：被调用 -外部函数
'         调  用 -无
'========================================================================


Private Sub GetStdName(ByRef vsPath As String)
    If InStr(1, vsPath, " ") > 0 Then
        vsPath = """" & vsPath & """"
    End If
End Sub

Private Sub Class_Initialize()

    ''' arj程序所在的目录
    msArjPath = Replace(App.Path + "\sinfarch", "\\", "\")
    If Right(msArjPath, 1) <> "\" Then msArjPath = msArjPath & "\"
    msArjPath = msArjPath & "arj.exe"
    
    GetStdName msArjPath

End Sub