sendmail.bas

金算盘软件代码

Attribute VB_Name = "SendMail"
Option Explicit

''**********API函数声明**************
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function GetDiskFreeSpace Lib "kernel32" Alias "GetDiskFreeSpaceA" (ByVal lpRootPathName As String, lpSectorsPerCluster As Long, lpBytesPerSector As Long, lpNumberOfFreeClusters As Long, lpTtoalNumberOfClusters As Long) As Long
Private Declare Function GetLogicalDriveStrings Lib "kernel32" Alias "GetLogicalDriveStringsA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Public Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Private Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long
Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Private Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long

''**********压缩函数声明**************
Private Declare Function addZIP Lib "azip32.dll" () As Integer
Private Declare Function addZIP_ArchiveName Lib "azip32.dll" (ByVal lpStr As String) As Integer
Private Declare Function addZIP_Comment Lib "azip32.dll" (ByVal lpStr As String) As Integer
Private Declare Function addZIP_Include Lib "azip32.dll" (ByVal lpStr As String) As Integer
Private Declare Function addZIP_IncludeListFile Lib "azip32.dll" (ByVal lpStr As String) As Integer
Private Declare Sub addZIP_Initialise Lib "azip32.dll" ()
Private Declare Function addZIP_SaveStructure Lib "azip32.dll" (ByVal Int16 As Integer) As Integer
Private Declare Function addZIP_SetArchiveDate Lib "azip32.dll" (ByVal Int16 As Integer) As Integer
Private Declare Function addZIP_SetCompressionLevel Lib "azip32.dll" (ByVal Int16 As Integer) As Integer
Private Declare Function addZIP_Span Lib "azip32.dll" (ByVal Int16 As Integer) As Integer
Private Declare Function addZIP_UseLFN Lib "azip32.dll" (ByVal Int16 As Integer) As Integer
''**********解压函数声明**************
Private Declare Function addUNZIP Lib "aunzip32.dll" () As Long
Private Declare Function addUNZIP_ArchiveName Lib "aunzip32.dll" (ByVal FileName As String) As Integer
Private Declare Function addUNZIP_ExtractTo Lib "aunzip32.dll" (ByVal cPath As String) As Integer
Private Declare Function addUNZIP_Include Lib "aunzip32.dll" (ByVal files As String) As Integer
Private Declare Sub addUNZIP_Initialise Lib "aunzip32.dll" ()

Private Const azCOMPRESSION_MAXIMUM = &H3
Private Const azCOMPRESSION_MINIMUM = &H1
Private Const azCOMPRESSION_NONE = &H0
Private Const azCOMPRESSION_NORMAL = &H2

Private Const azSTRUCTURE_ABSOLUTE = &H2
Private Const azSTRUCTURE_NONE = &H0
Private Const azSTRUCTURE_RELATIVE = &H1


Public Function CompressFile(destName As String, sourceName As String) As Boolean
  Dim i As Integer
  Dim sFiles As String
  
  addZIP_Initialise
  
  i = addZIP_ArchiveName(sourceName)
  i = addZIP_Include(destName)
  i = addZIP_SaveStructure(azSTRUCTURE_NONE)
  i = addZIP_SetCompressionLevel(azCOMPRESSION_MINIMUM) ''最小化压缩
  i = addZIP_UseLFN(1)  ''允许使用长文件名
  i = addZIP()
  If i <= 0 Then
     MsgBox "文件压缩出错（选择的驱动器不可写或空间不够）", vbInformation, "备份帐套"
     CompressFile = False
     Exit Function
  End If
  CompressFile = True
End Function

Public Function DecompFile(sourceName As String, Optional destPath As String = "") As Boolean
Dim i As Integer
Dim lngFileHandle    As Long
Dim strDestPath      As String
Dim udtWin32FindData As WIN32_FIND_DATA

addUNZIP_Initialise

i = addZIP_UseLFN(1)  ''允许使用长文件名
i = addUNZIP_ArchiveName(sourceName)
If destPath <> "" Then
  i = addUNZIP_ExtractTo("C:\WrTemp")
End If
i = addUNZIP
If i <= 0 Then
  MsgBox "文件解压出错", vbInformation, ""
  DecompFile = False
  Exit Function
End If
DecompFile = True
End Function