VB调用WinRAR
VB如何调用帮助文档
VB如何调用帮助文档Private Declare Function ShellExecute Lib "shell32.dll " Alias "ShellExecuteA " (ByV al hwnd As Long, ByV al lpOperation As String, ByV al lpFile A s String, ByV al lpParameters As String, ByV al lpDirectory As String, By V al nShowCmd As Long) As Long'调用帮助call ShellExecute (Me.hwnd, "open ", app.path & "help.chm ", vbNullString, vbNullString, 5)/Expert/topic/1596/1596514.xml?temp=1.757449E-02看懂了吗？跟你解释一下这是一个很常用的api函数声明。
Private Declare Function ShellExecute Lib "shell32.dll " Alias "ShellExecuteA " (ByV al hwnd As Long, ByV al lpOperation As String, ByV al lpFile A s String, ByV al lpParameters As String, ByV al lpDirectory As String, By V al nShowCmd As Long) As Long解释一下几个参数。
hwnd (Long)指定一个窗口的句柄，有时候，windows程序有必要在创建自己的主窗口前显示一个消息框或打开一个文件lpOperation （String)指定字串“open”来打开lpFlie文档，或指定“Print”来打印它lpFile （String），想用关联程序打印或打开一个程序名或文件名lpParameters (String)如lpszFlie是可执行文件，则这个字串包含传递给执行程序的参数lpDirectory (String)想使用的完整路径nShowCmd (Long)定义了如何显示启动程序的常数值。
VB中调用Windows API的注意事项
VB中调用Windows API的注意事项API说到底就是一系列的底层函数，是系统提供给用户用于进入操作系统核心，进行高级编程的途径。
通过在Visual Basic应用程序中声明外部过程就能够访问Windows API(以及其它的外部DLLs)。
在声明了过程之后，调用它的方法与调用Visual Basic自己的过程相同。
Visual Basic (VB)作为一种高效编程环境，它封装了部分Windows API函数，但也牺牲了一些API的功能。
调用API时稍有不慎就可能导致API编程错误，出现难于捕获或间歇性错误，甚至出现程序崩溃。
要减少API编程错误，提高VB调用API时的安全性，应重点注意下列八个问题：(1)指定“Option Explicit”编程前最好将VB编程环境中的“Require Variable Declaration(要求变量申明)项选中。
如果该项未被指定，任何简单的录入错误都可能会产生一个“Variant”变量，在调用API时，VB对该变量进行强制转换以避免冲突，这样一来，VB就会为字符串、长整数、整数、浮点数等各种类型传递NULL值，导致程序无法正常运行。
(2)注意VB整数和Win32整数的区别在VB环境下，涉及到的所有integer(整型数)，都是16位，而一旦涉及C／C＋＋Win32文档时，则是32位，阅读与Windows API函数或与32位动态链接库有关的资料或应用程序时，尤其要注意分析理解环境背景，以利于分清数据类型和数据结构，正确地声明API函数。
(3)减少和避免使用As Any虽然用As Any的方法声明库，可使Windows API函数能接受多种类型的参数，但更严重的是，即使是一个很小的错误，比如遗漏类型标识符或错误地使用了ByVal关键字，都可能导致系统崩溃或很难发现的其他数据错误。
(4)注意检查参数类型API错误中，除了因遗漏ByVal关键字导致的错误外，大约有50％是因为声明中有不正确的参数类型。
VB编程实现lzw压缩算法
做出差不多这样的控件就好了解压可以不要下面是lzw无损压缩算法的源代码vb的希望帮改改弄个控件急用谢谢了Attribute VB_Name = "Comp_LZW_Predefined"'Option Compare DatabaseOption Explicit'This is a 2 run methodPrivate MaxChars As LongPrivate TempStream() As BytePrivate OutStream() As BytePrivate OutPos As LongPrivate OutByteBuf As IntegerPrivate OutBitCount As IntegerPrivate ReadBitPos As IntegerPrivate Dict() As String 'the dictionariesPrivate DictPos As Integer 'the position to store the next charactersPrivate SearchPos() As LongPrivate SpeedSearch() As LongPrivate ActDict As Integer 'actual dictionaryPrivate maxCharLenght As Byte 'Maximum stringlength in de dictionaryPrivate maxDictDeep As Long 'maximum stored words per dictionaryPrivate TotBitDeep As Integer 'total bitlength per characterPrivate MaxBitDeep As IntegerPrivate minBitDeep As IntegerPrivate StartDict As Long 'startposition of de dictionary Private NewBitLengt As LongPrivate EscapeCode As LongPrivate WaitForLessBits As Long'The next varariable is used to detect the kind of ascii's used'0 = all ascii'1 = 2 ascii determen the range that is used'<=127 following codes are used'>127 following codes are not usedPrivate DictCode As IntegerPrivate DictChars(127) As BytePublic Sub Compress_LZWPre(FileArray() As Byte)Dim ByteV alue As ByteDim TempByte As LongDim ExtraBits As IntegerDim DictStr As StringDim NewStr As StringDim CompPos As LongDim DictV al As LongDim DictPosit As LongDim DictPositOld As LongDim FilePos As LongDim FileLenght As LongDim BitLengthCount As IntegerDim Temp As LongDim MostUsed1 As IntegerDim MostUsed2 As IntegerDim MostCount1 As LongDim MostCount2 As LongDim MinCount As LongDim CharCount(255) As LongDim X As LongDim DictNu As IntegerDim CheckRange As BooleanDim MaxDictPagesInBites As LongMaxDictPagesInBites = CLng(1024) * DictionarySize - 1 DictNu = 0DictCode = 0'Find the used characters and wich are most commonFor X = 0 To UBound(FileArray)CharCount(FileArray(X)) = CharCount(FileArray(X)) + 1If CharCount(FileArray(X)) = 1 Then DictCode = DictCode + 1Next'this part finds out wich 2 characters are most common so that we can predefine them in the dictionareFor X = 0 To 255If CharCount(X) > MinCount ThenIf CharCount(X) > MostCount2 ThenIf MostCount1 > MostCount2 ThenMostCount2 = CharCount(X)MostUsed2 = XElseMostCount1 = CharCount(X)MostUsed1 = XEnd IfElseMostCount1 = CharCount(X)MostUsed1 = XEnd IfIf MostCount1 > MostCount2 ThenMinCount = MostCount2ElseMinCount = MostCount1End IfEnd IfNext'this part is used to check wich codes are used so we can limiting the dictionary size If DictCode = 255 ThenDictCode = 0Else'this part is used to check if we have a follower range of charactersFor X = 0 To 255If CharCount(X) > 0 ThenDictChars(0) = XExit ForEnd IfNextFor X = 255 To 0 Step -1If CharCount(X) > 0 ThenDictChars(1) = XExit ForEnd IfNextCheckRange = TrueFor X = DictChars(0) To DictChars(1)If CharCount(X) = 0 ThenCheckRange = FalseExit ForEnd IfNextIf CheckRange = False ThenSelect Case DictCodeCase Is <= 127For X = 0 To 255If CharCount(X) > 0 ThenDictChars(DictNu) = XDictNu = DictNu + 1End IfNextCase ElseFor X = 0 To 255If CharCount(X) = 0 ThenDictChars(DictNu) = XDictNu = DictNu + 1End IfNextEnd SelectElseDictCode = 1End IfEnd If'init the dictionaryCall Init_DictvarPre(MaxDictPagesInBites)'create the dictionaryCall Create_Dict_Pre'add some predefined dictionare entriesCall Create_Additional_Dict(MostUsed1, MostUsed2)FileLenght = UBound(FileArray)ReDim OutStream(FileLenght + 10)OutPos = 0Call AddBitsToOutStream(CLng(maxCharLenght), 8)Call AddBitsToOutStream(CLng(MaxBitDeep), 8)'add the dictionary codeCall AddBitsToOutStream(CLng(DictCode), 8)If DictCode = 1 ThenCall AddBitsToOutStream(CLng(DictChars(0)), 8)Call AddBitsToOutStream(CLng(DictChars(1)), 8)ElseIf DictCode > 1 ThenIf DictCode > 127 Then DictCode = 256 - DictCodeFor X = 0 To DictCode - 1Call AddBitsToOutStream(CLng(DictChars(X)), 8) NextEnd If'add the two mostused charactersCall AddBitsToOutStream(CLng(MostUsed1), 8)Call AddBitsToOutStream(CLng(MostUsed2), 8)'whe are ready to packFilePos = 0CompPos = 7DictStr = ""ExtraBits = 0Do Until FilePos > FileLenghtByteV alue = SearchPre(Chr(FileArray(FilePos)))FilePos = FilePos + 1NewStr = DictStr & Dict(ByteV alue)DictPosit = SearchPre(NewStr)If DictPosit <> maxDictDeep + 1 ThenDictStr = NewStrDictPositOld = DictPositElseDo While DictPositOld > (2 ^ TotBitDeep) - 1Call AddBitsToOutStream(NewBitLengt, TotBitDeep)TotBitDeep = TotBitDeep + 1LoopCall AddBitsToOutStream(DictPositOld, TotBitDeep)Call AddToDictPre(NewStr, 1)DictPositOld = ByteV alueDictStr = Dict(ByteV alue)End IfLoopDo While DictPositOld > (2 ^ TotBitDeep) - 1Call AddBitsToOutStream(NewBitLengt, TotBitDeep)TotBitDeep = TotBitDeep + 1LoopCall AddBitsToOutStream(DictPositOld, TotBitDeep)BitLengthCount = BitLengthCount - 1If BitLengthCount = 0 ThenIf TotBitDeep > minBitDeep Then TotBitDeep = TotBitDeep - 1BitLengthCount = WaitForLessBitsEnd IfCall AddBitsToOutStream(EscapeCode, TotBitDeep)Do While OutBitCount > 0Call AddBitsToOutStream(0, 1)LoopReDim FileArray(OutPos - 1)Call CopyMem(FileArray(0), OutStream(0), OutPos)End SubPublic Sub DeCompress_LZWPre(FileArray() As Byte)Dim ReadBits As IntegerDim DictV al As LongDim TempByte As LongDim OldKarV alue As LongDim DeComPByte() As ByteDim DeCompPos As LongDim FilePos As LongDim FileLenght As LongDim InpPos As LongDim BitLengthCount As IntegerDim X As LongInpPos = 0ReadBitPos = 0maxCharLenght = ReadBitsFromArray(FileArray, InpPos, 8)maxDictDeep = (2 ^ ReadBitsFromArray(FileArray, InpPos, 8)) - 1'initialize the dictionaryCall Init_DictvarPre(maxDictDeep)DictCode = ReadBitsFromArray(FileArray, InpPos, 8)If DictCode = 1 ThenDictChars(0) = ReadBitsFromArray(FileArray, InpPos, 8)DictChars(1) = ReadBitsFromArray(FileArray, InpPos, 8)ElseIf DictCode > 1 ThenIf DictCode > 127 Then DictCode = 256 - DictCodeFor X = 0 To DictCode - 1DictChars(X) = ReadBitsFromArray(FileArray, InpPos, 8)NextEnd If'predefine the dictionaryCall Create_Dict_Pre'add some predefined dictionare entriesCall Create_Additional_Dict(ReadBitsFromArray(FileArray, InpPos, 8), ReadBitsFromArray(FileArray, InpPos, 8))'whe are ready to unpackReDim OutStream(500)OldKarV alue = -1DoDictV al = ReadBitsFromArray(FileArray, InpPos, TotBitDeep)If DictV al = EscapeCode Then Exit DoIf DictV al = NewBitLengt ThenTotBitDeep = TotBitDeep + 1ElseIf Dict(DictV al) <> "" ThenCall AddASC2OutStream(Dict(DictV al))If OldKarV alue <> -1 Then Call AddToDictPre(Dict(OldKarV alue) & Left(Dict(DictV al), 1), 0)ElseCall AddToDictPre(Dict(OldKarV alue) & Left(Dict(OldKarV alue), 1), 0)Call AddASC2OutStream(Dict(DictV al))End IfOldKarV alue = DictV alEnd IfLoopOutPos = OutPos - 1ReDim FileArray(OutPos)Call CopyMem(FileArray(0), OutStream(0), OutPos + 1)End SubPrivate Sub Init_DictvarPre(Optional MaxDictPagesInBites As Long = 512, Optional StoreTilCharLenght As Byte = 50)Dim X As IntegerIf MaxDictPagesInBites > 65535 ThenMaxDictPagesInBites = 65535ElseIf MaxDictPagesInBites < 255 ThenMaxDictPagesInBites = 255End IfFor X = 0 To 16If MaxDictPagesInBites <= 2 ^ X ThenMaxDictPagesInBites = 2 ^ XMaxBitDeep = XExit ForEnd IfNextMaxDictPagesInBites = MaxDictPagesInBites - 1maxCharLenght = StoreTilCharLenghtmaxDictDeep = MaxDictPagesInBitesOutPos = 0OutByteBuf = 0OutBitCount = 0ReadBitPos = 0ReDim Dict(maxDictDeep)ReDim SearchPos(maxDictDeep - 255, maxCharLenght) ReDim SpeedSearch(maxDictDeep - 255)End SubPrivate Sub Create_Dict_Pre()Dim X As IntegerDim DictNu As IntegerDim ReadDict As IntegerDictNu = 0ReadDict = 0Select Case DictCodeCase 0For X = 0 To 255Dict(DictNu) = Chr(X)DictNu = DictNu + 1NextCase 1For X = DictChars(0) To DictChars(1)Dict(DictNu) = Chr(X)DictNu = DictNu + 1NextCase Is <= 127For X = 0 To DictCode - 1Dict(DictNu) = Chr(DictChars(X))DictNu = DictNu + 1NextCase ElseFor X = 0 To 255If DictChars(ReadDict) <> X ThenDict(DictNu) = Chr(X)DictNu = DictNu + 1ElseReadDict = ReadDict + 1End IfNextEnd SelectNewBitLengt = DictNuEscapeCode = DictNu + 1StartDict = DictNu + 2For X = 0 To 16If StartDict < 2 ^ X ThenminBitDeep = XTotBitDeep = minBitDeepExit ForEnd IfNextDictPos = StartDictEnd SubPrivate Sub Create_Additional_Dict(value1 As Integer, V alue2 As Integer) Dim X As LongFor X = 0 To NewBitLengt - 1Call AddToDictPre(Dict(X) & Chr(value1), 0)NextFor X = 0 To NewBitLengt - 1Call AddToDictPre(Dict(X) & Chr(V alue2), 0)NextEnd SubPrivate Sub Clean_DictionaryPre()Dim X As LongDim Y As LongReDim Dict(maxDictDeep)ReDim SearchPos(maxDictDeep - 255, maxCharLenght)ReDim SpeedSearch(maxDictDeep - 255)For X = 0 To 255Dict(X) = Chr(X)NextFor X = 256 To maxDictDeepIf Dict(X) = "" Then Exit For Else Dict(X) = ""NextFor X = 0 To maxDictDeep - 255SpeedSearch(X) = 0For Y = 0 To maxCharLenghtIf SearchPos(X, Y) = 0 Then Exit For Else SearchPos(X, Y) = 0 NextNextCall Init_DictStartPreEnd SubPrivate Sub Init_DictStartPre()DictPos = StartDictEnd SubPrivate Function SearchPre(Char As String) As LongDim X As LongDim Step As LongStep = 0If Len(Char) = 1 ThenFor X = 0 To DictCode - 1If Dict(X) = Char ThenSearchPre = XExit FunctionEnd IfNextElseIf Len(Char) < maxCharLenght ThenX = SearchPos(Step, Len(Char))Do While X <> 0If Dict(X) = Char ThenSearchPre = XExit FunctionEnd IfStep = Step + 1X = SearchPos(Step, Len(Char))LoopEnd IfSearchPre = maxDictDeep + 1End FunctionPrivate Sub AddToDictPre(Char As String, Comp1Decomp0 As Byte)If Len(Char) = 1 Or Len(Char) - 2 > maxCharLenght Then Exit SubIf DictPos + Comp1Decomp0 >= maxDictDeep Then Exit SubDict(DictPos) = CharSearchPos(SpeedSearch(Len(Char)), Len(Char)) = DictPosSpeedSearch(Len(Char)) = SpeedSearch(Len(Char)) + 1DictPos = DictPos + 1End SubPrivate Sub AddASC2OutStream(Text As String)Dim X As LongIf OutPos + Len(Text) > UBound(OutStream) Then ReDim Preserve OutStream(OutPos + Len(Text) + 500)For X = 1 To Len(Text)OutStream(OutPos) = ASC(Mid(Text, X, 1))OutPos = OutPos + 1NextEnd Sub'this sub will add an amount of bits into the outputstreamPrivate Sub AddBitsToOutStream(Number As Long, Numbits As Integer)Dim X As LongFor X = Numbits - 1 To 0 Step -1OutByteBuf = OutByteBuf * 2 + (-1 * ((Number And CDbl(2 ^ X)) > 0))OutBitCount = OutBitCount + 1If OutBitCount = 8 ThenOutStream(OutPos) = OutByteBufOutBitCount = 0OutByteBuf = 0OutPos = OutPos + 1If OutPos > UBound(OutStream) ThenReDim Preserve OutStream(OutPos + 500)End IfEnd IfNextEnd Sub'this sub will read an amount of bits from the inputstreamPrivate Function ReadBitsFromArray(FromArray() As Byte, FromPos As Long, Numbits As Integer) As LongDim X As IntegerDim Temp As LongFor X = 1 To NumbitsTemp = Temp * 2 + (-1 * ((FromArray(FromPos) And 2 ^ (7 - ReadBitPos)) > 0))ReadBitPos = ReadBitPos + 1If ReadBitPos = 8 ThenIf FromPos + 1 > UBound(FromArray) ThenDo While X < NumbitsTemp = Temp * 2X = X + 1LoopFromPos = FromPos + 1Exit ForEnd IfFromPos = FromPos + 1ReadBitPos = 0End IfNextReadBitsFromArray = TempEnd Function。
VB调用WinRAR
与WinRAR以最快方式压缩ZIP比较，255M的文件Level=0时用时秒大小95.1MLevel=255时用时秒大小91.6MWinRAR最快压缩ZIP 用时秒大小58.6M标准RAR压缩，我看了一下，实在太慢，也就没试了，估计要几分钟才会有结果。
从速度看，基本持平了，这个算法虽然最大压缩能力有限，但感觉设计得很巧妙，每次都基于动态表，使软件可以做得很小巧，资源占用也很少。
非常值得收藏！'测试窗体中的代码Option ExplicitPrivate WithEvents ObjZip As ClassZipPrivate BgTime As SinglePrivate Sub Command1_Click()BgTime = Timer= False= FalseWith ObjZip.InputFileName =.OutputFileName =.IsCompress = True.CompressLevel = Val.BeginProcssEnd With= Round(Timer - BgTime, 2) & "秒"= True= TrueEnd SubPrivate Sub Command2_Click()BgTime = Timer= False= FalseWith ObjZip.InputFileName =.OutputFileName =.IsCompress = False.BeginProcssEnd WithLabel1 = Round(Timer - BgTime, 2) & "秒"= True= TrueEnd SubPrivate Sub Command3_Click()= TrueEnd SubPrivate Sub Form_Load()Set ObjZip = New ClassZip= "压缩"= "解压"= "中断"End SubPrivate Sub Form_Unload(Cancel As Integer)Set ObjZip = NothingEnd SubPrivate Sub ObjZip_FileProgress(sngPercentage As Single) Label1 = Int(sngPercentage * 100) & "%"End SubPrivate Sub ObjZip_ProcssError(ErrorDescription As String) MsgBox ErrorDescriptionEnd Sub'ClassZip类中的声明与属性、方法、事件Option ExplicitPublic Event FileProgress(sngPercentage As Single)Public Event ProcssError(ErrorDescription As String) Private Type FileHeaderHeaderTag As String * 3HeaderSize As IntegerFlag As ByteFileLength As LongVersion As IntegerEnd TypePrivate mintCompressLevel As LongPrivate m_bEnableProcss As BooleanPrivate m_bCompress As BooleanPrivate m_strInputFileName As StringPrivate m_strOutputFileName As StringPrivate Const mcintWindowSize As Integer = &H1000 Private Const mcintMaxMatchLen As Integer = 18Private Const mcintMinMatchLen As Integer = 3Private Const mcintNull As Long = &H1000Private Const mcstrSignature As String = "FMZ"Private Declare Sub CopyMemory Lib "Kernel32" Alias "RtlMoveMemory" (pDest As Any, pSou rce As Any, ByVal dwLength As Long)Public Sub BeginProcss()If m_bCompress ThenCompressElseDecompressEnd IfEnd SubPrivate Function LastError(ErrNo As Integer) As StringSelect Case ErrNoCase 1LastError = "待压缩文件未设置或不存在"Case 2LastError = "待压缩文件长度太小"Case 3LastError = "待压缩文件已经过压缩"Case 4LastError = "待解压文件未设置或不存在"Case 5LastError = "待解压文件格式不对或为本软件不能认别的高版本软件所压缩"Case 254LastError = "用户取消了操作"Case 255LastError = "未知错误"End SelectEnd FunctionPublic Property Get CompressLevel() As IntegerCompressLevel = mintCompressLevel \ 16End PropertyPublic Property Let CompressLevel(ByVal intValue As Integer)mintCompressLevel = intValue * 16If mintCompressLevel < 0 Then mintCompressLevel = 0End PropertyPublic Property Get IsCompress() As BooleanIsCompress = m_bCompressEnd PropertyPublic Property Let IsCompress(ByVal bValue As Boolean)m_bCompress = bValueEnd PropertyPublic Property Let CancelProcss(ByVal bValue As Boolean)m_bEnableProcss = Not bV alueEnd PropertyPublic Property Get InputFileName() As StringInputFileName = m_strInputFileNameEnd PropertyPublic Property Get OutputFileName() As StringOutputFileName = m_strOutputFileNameEnd PropertyPublic Property Let OutputFileName(ByVal strValue As String)m_strOutputFileName = strValueEnd PropertyPublic Property Let InputFileName(ByVal strValue As String)m_strInputFileName = strValueEnd PropertyPrivate Sub Class_Terminate()m_bEnableProcss = FalseEnd SubPrivate Sub Compress()Dim lngTemp As Long, intCount As IntegerDim intBufferLocation As IntegerDim intMaxLen As IntegerDim intNext As IntegerDim intPrev As IntegerDim intMatchPos As IntegerDim intMatchLen As IntegerDim intInputFile As IntegerDim intOutputFile As IntegerDim aintWindowNext(mcintWindowSize + 1 + mcintWindowSize) As IntegerDim aintWindowPrev(mcintWindowSize + 1) As IntegerDim intByteCodeWritten As LongDim intBitCount As IntegerDim abytWindow(mcintWindowSize + mcintMaxMatchLen) As ByteDim udtFileH As FileHeaderDim strOutTmpFile As StringDim lngBytesRead As LongDim lngFileLength As LongDim lngCurWritten As LongDim lngInBufLen As Long, abytInputBuffer() As Byte, abytOutputBuffer() As Byte Dim lngOutBufLen As Long, lngInPos As Long, lngOutPos As LongDim intErrNo As IntegerOn Error GoTo PROC_ERRm_bEnableProcss = TrueIf Len(Dir(m_strInputFileName)) = 0 Or Len(m_strInputFileName) = 0 Then intErrNo = 1: GoTo PROC_ERRIf Len(m_strOutputFileName) = 0 Then m_strOutputFileName = m_strInputFileNamestrOutTmpFile = m_strOutputFileName & ".tmp"If Len(Dir(strOutTmpFile)) > 0 Then Kill strOutTmpFileIf FileLen(m_strInputFileName) < 100 Then intErrNo = 2: GoTo PROC_ERRintInputFile = FreeFileOpen m_strInputFileName For Binary Access Read As intInputFileGet intInputFile, , udtFileHSeek #intInputFile, 1If = mcstrSignature Then intErrNo = 3: GoTo PROC_ERRintOutputFile = FreeFileOpen strOutTmpFile For Binary As intOutputFileFor intCount = 0 To mcintWindowSizeaintWindowPrev(intCount) = mcintNullabytWindow(intCount) = &H20NextCopyMemory aintWindowNext(0), aintWindowPrev(0), (mcintWindowSize + 1) * 2CopyMemory aintWindowNext(mcintWindowSize + 1), aintWindowPrev(0), mcintWindowSize * 2CopyMemory abytWindow(mcintWindowSize + 1), abytWindow(0), mcintMaxMatchLen - 1intByteCodeWritten = 1lngFileLength = LOF(intInputFile)lngInBufLen = &HA000&lngOutBufLen = &HA000&If lngInBufLen > lngFileLength Then lngInBufLen = lngFileLengthReDim abytInputBuffer(lngInBufLen - 1)ReDim abytOutputBuffer(lngOutBufLen + 17)With udtFileH.HeaderSize = Len(udtFileH)lngCurWritten = .HeaderSize + 1.HeaderTag = mcstrSignature.FileLength = lngFileLength.Version =.Flag = 0End WithintMaxLen = mcintMaxMatchLenlngBytesRead = mcintMaxMatchLenlngInPos = mcintMaxMatchLenintBitCount = 1Put intOutputFile, , udtFileHGet intInputFile, , abytInputBufferCopyMemory abytWindow(0), abytInputBuffer(0), mcintMaxMatchLenCopyMemory abytWindow(mcintWindowSize), abytInputBuffer(0), mcintMaxMatchLenDo While intMaxLenintMatchPos = 0intMatchLen = 0intPrev = aintWindowNext(((&H100& * abytWindow(intBufferLocation + 1) + abytWindow(int BufferLocation)) And &HFFF) + mcintWindowSize + 1)intCount = 0Do Until intCount > mintCompressLevel Or intPrev = mcintNullintNext = 0Do While (abytWindow(intPrev + intNext) = abytWindow(intBufferLocation + intNext)) And int Next < mcintMaxMatchLenintNext = intNext + 1LoopIf intNext > intMatchLen ThenintMatchLen = intNextintMatchPos = intPrevIf intNext = mcintMaxMatchLen ThenaintWindowNext(aintWindowPrev(intPrev)) = aintWindowNext(intPrev)aintWindowPrev(aintWindowNext(intPrev)) = aintWindowPrev(intPrev)aintWindowNext(intPrev) = mcintNullaintWindowPrev(intPrev) = mcintNullExit DoEnd IfEnd IfintPrev = aintWindowNext(intPrev)intCount = intCount + 1LoopIf intBitCount And &H100 ThenlngOutPos = intByteCodeWrittenIf intByteCodeWritten > lngOutBufLen ThenPut intOutputFile, lngCurWritten, abytOutputBufferDoEventsIf m_bEnableProcss = False Then intErrNo = 254: GoTo PROC_ERRlngCurWritten = lngCurWritten + intByteCodeWrittenlngOutPos = 0End IfintByteCodeWritten = lngOutPos + 1intBitCount = 1abytOutputBuffer(lngOutPos) = 0End IfIf intMatchLen < mcintMinMatchLen ThenintMatchLen = 1abytOutputBuffer(intByteCodeWritten) = abytWindow(intBufferLocation)abytOutputBuffer(lngOutPos) = abytOutputBuffer(lngOutPos) Or intBitCountEnd IfIf intMatchLen > 1 ThenIf intMatchLen > intMaxLen Then intMatchLen = intMaxLenabytOutputBuffer(intByteCodeWritten) = intMatchPos And &HFFintByteCodeWritten = intByteCodeWritten + 1abytOutputBuffer(intByteCodeWritten) = (((intMatchPos \ 16) And &HF0) Or intMatchLen - mci ntMinMatchLen) And &HFFEnd IfintByteCodeWritten = intByteCodeWritten + 1intBitCount = intBitCount * 2Do While intMatchLenintPrev = intBufferLocation + mcintMaxMatchLenintNext = intPrev And &HFFFIf aintWindowPrev(intNext) <> mcintNull ThenaintWindowNext(aintWindowPrev(intNext)) = aintWindowNext(intNext)aintWindowPrev(aintWindowNext(intNext)) = aintWindowPrev(intNext)aintWindowNext(intNext) = mcintNullaintWindowPrev(intNext) = mcintNullEnd IfIf lngInPos < lngInBufLen ThenabytWindow(intNext) = abytInputBuffer(lngInPos)If intPrev >= mcintWindowSize Then abytWindow(intPrev) = abytInputBuffer(lngInPos)lngBytesRead = lngBytesRead + 1lngInPos = lngInPos + 1If lngInPos >= lngInBufLen ThenIf lngFileLength > lngBytesRead ThenIf lngInBufLen > lngFileLength - lngBytesRead ThenlngInBufLen = lngFileLength - lngBytesReadReDim abytInputBuffer(lngInBufLen - 1)End IfGet intInputFile, , abytInputBufferlngInPos = 0RaiseEvent FileProgress(lngBytesRead / lngFileLength)DoEventsIf m_bEnableProcss = False Then intErrNo = 254: GoTo PROC_ERREnd IfEnd IfEnd IfintPrev = ((&H100& * abytWindow(intBufferLocation + 1) + abytWindow(intBufferLocation)) A nd &HFFF) + mcintWindowSize + 1intNext = aintWindowNext(intPrev)aintWindowPrev(intBufferLocation) = intPrevaintWindowNext(intBufferLocation) = intNextaintWindowNext(intPrev) = intBufferLocationIf intNext <> mcintNull Then aintWindowPrev(intNext) = intBufferLocationintBufferLocation = (intBufferLocation + 1) And &HFFFintMatchLen = intMatchLen - 1LoopIf lngInPos >= lngInBufLen Then intMaxLen = intMaxLen - 1LoopIf intByteCodeWritten > 0 ThenReDim Preserve abytOutputBuffer(intByteCodeWritten - 1)Put intOutputFile, lngCurWritten, abytOutputBufferEnd IfClose intInputFileClose intOutputFileIf Len(Dir(m_strOutputFileName)) > 0 Then Kill m_strOutputFileNameName strOutTmpFile As m_strOutputFileNameRaiseEvent FileProgress(1)Exit SubPROC_ERR:Close intOutputFileClose intInputFileIf Len(Dir(strOutTmpFile)) > 0 And Len(strOutTmpFile) > 0 Then Kill strOutTmpFileIf intErrNo = 0 Then intErrNo = 255RaiseEvent ProcssError(LastError(intErrNo))End SubPrivate Sub Decompress()Dim intTemp As IntegerDim intBufferLocation As IntegerDim intLength As IntegerDim bytHiByte As IntegerDim bytLoByte As IntegerDim intWindowPosition As IntegerDim lngFlags As LongDim intInputFile As IntegerDim intOutputFile As IntegerDim abytWindow(mcintWindowSize + mcintMaxMatchLen) As ByteDim strOutTmpFile As StringDim lngBytesRead As LongDim lngBytesWritten As LongDim lngFileLength As LongDim lngOriginalFileLen As LongDim lngInBufLen As Long, abytInBuf() As Byte, abytOutBuf() As ByteDim lngOutBufLen As Long, lngInPos As Long, lngOutPos As LongDim udtFileH As FileHeaderDim intErrNo As IntegerOn Error GoTo PROC_ERRm_bEnableProcss = TrueIf Len(Dir(m_strInputFileName)) = 0 Or Len(m_strInputFileName) = 0 Then intErrNo = 4: GoTo PROC_ERRIf Len(m_strOutputFileName) = 0 Then m_strOutputFileName = m_strInputFileNamestrOutTmpFile = m_strOutputFileName & ".tmp"If Len(Dir(strOutTmpFile)) > 0 Then Kill strOutTmpFileintInputFile = FreeFileOpen m_strInputFileName For Binary Access Read As intInputFilelngFileLength = LOF(intInputFile)Get intInputFile, , udtFileHIf = mcstrSignature And <= ThenSeek #intInputFile, + 1intOutputFile = FreeFileOpen strOutTmpFile For Binary As intOutputFilelngOriginalFileLen =lngFileLength = lngFileLength -lngInBufLen = &H20000lngOutBufLen = &H20000If lngInBufLen > lngFileLength Then lngInBufLen = lngFileLengthReDim abytInBuf(lngInBufLen - 1)ReDim abytOutBuf(lngOutBufLen - 1)Get intInputFile, , abytInBufDo While lngBytesWritten < lngOriginalFileLenlngFlags = lngFlags \ 2If (lngFlags And &H100) = 0 ThenlngFlags = &HFF00& Or abytInBuf(lngInPos)lngBytesRead = lngBytesRead + 1lngInPos = lngInPos + 1If lngInPos >= lngInBufLen ThenIf lngFileLength > lngBytesRead ThenIf lngInBufLen > lngFileLength - lngBytesRead ThenlngInBufLen = lngFileLength - lngBytesReadReDim abytInBuf(lngInBufLen - 1)End IfGet intInputFile, , abytInBufDoEventsIf m_bEnableProcss = False Then intErrNo = 254: GoTo PROC_ERR lngInPos = 0End IfEnd IfEnd IfIf (lngFlags And 1) ThenabytWindow(intWindowPosition) = abytInBuf(lngInPos)abytOutBuf(lngOutPos) = abytInBuf(lngInPos)lngBytesRead = lngBytesRead + 1lngInPos = lngInPos + 1lngBytesWritten = lngBytesWritten + 1lngOutPos = lngOutPos + 1intWindowPosition = (intWindowPosition + 1) And &HFFFIf lngInPos >= lngInBufLen ThenIf lngFileLength > lngBytesRead ThenIf lngInBufLen > lngFileLength - lngBytesRead ThenlngInBufLen = lngFileLength - lngBytesReadReDim abytInBuf(lngInBufLen - 1)End IfGet intInputFile, , abytInBufDoEventsIf m_bEnableProcss = False Then intErrNo = 254: GoTo PROC_ERR lngInPos = 0End IfEnd IfIf lngOutPos >= lngOutBufLen ThenPut intOutputFile, , abytOutBuflngOutPos = 0RaiseEvent FileProgress(lngBytesWritten / lngOriginalFileLen)DoEventsIf m_bEnableProcss = False Then intErrNo = 254: GoTo PROC_ERR End IfElsebytHiByte = abytInBuf(lngInPos)lngBytesRead = lngBytesRead + 1lngInPos = lngInPos + 1If lngInPos >= lngInBufLen ThenIf lngFileLength > lngBytesRead ThenIf lngInBufLen > lngFileLength - lngBytesRead ThenlngInBufLen = lngFileLength - lngBytesReadReDim abytInBuf(lngInBufLen - 1)End IfGet intInputFile, , abytInBufDoEventsIf m_bEnableProcss = False Then intErrNo = 254: GoTo PROC_ERRlngInPos = 0End IfEnd IfbytLoByte = abytInBuf(lngInPos)intBufferLocation = ((bytLoByte And &HF0) * 16 + bytHiByte) And &HFFF intLength = (bytLoByte And &HF) + mcintMinMatchLenlngBytesRead = lngBytesRead + 1lngInPos = lngInPos + 1If lngInPos >= lngInBufLen ThenIf lngFileLength > lngBytesRead ThenIf lngInBufLen > lngFileLength - lngBytesRead ThenlngInBufLen = lngFileLength - lngBytesReadReDim abytInBuf(lngInBufLen - 1)End IfGet intInputFile, , abytInBufDoEventsIf m_bEnableProcss = False Then intErrNo = 254: GoTo PROC_ERRlngInPos = 0End IfEnd IfintTemp = intBufferLocation + intLengthDo While intBufferLocation < intTempabytOutBuf(lngOutPos) = abytWindow((intBufferLocation) And &HFFF)abytWindow(intWindowPosition) = abytOutBuf(lngOutPos)intBufferLocation = intBufferLocation + 1lngBytesWritten = lngBytesWritten + 1intWindowPosition = (intWindowPosition + 1) And &HFFFlngOutPos = lngOutPos + 1If lngOutPos >= lngOutBufLen ThenPut intOutputFile, , abytOutBuflngOutPos = 0RaiseEvent FileProgress(lngBytesWritten / lngOriginalFileLen)DoEventsIf m_bEnableProcss = False Then intErrNo = 254: GoTo PROC_ERREnd IfLoopEnd IfLoopIf lngOutPos > 0 ThenReDim Preserve abytOutBuf(lngOutPos - 1)Put intOutputFile, , abytOutBufEnd IfClose intOutputFileElseintErrNo = 5GoTo PROC_ERREnd IfClose intInputFileIf Len(Dir(m_strOutputFileName)) > 0 Then Kill m_strOutputFileNameName strOutTmpFile As m_strOutputFileNameRaiseEvent FileProgress(1)Exit SubPROC_ERR:Close intOutputFileClose intInputFileIf Len(Dir(strOutTmpFile)) > 0 And Len(strOutTmpFile) > 0 Then Kill strOutTmpFileIf intErrNo = 0 Then intErrNo = 255RaiseEvent ProcssError(LastError(intErrNo))End Sub'ClassZip类中的声明与属性、方法、事件Option ExplicitPublic Event FileProgress(sngPercentage As Single)Public Event ProcssError(ErrorDescription As String)Private Type FileHeaderHeaderTag As String * 3HeaderSize As IntegerFlag As ByteFileLength As LongVersion As IntegerEnd TypePrivate mintCompressLevel As LongPrivate m_bEnableProcss As BooleanPrivate m_bCompress As BooleanPrivate m_strInputFileName As StringPrivate m_strOutputFileName As StringPrivate Const mcintWindowSize As Integer = &H1000Private Const mcintMaxMatchLen As Integer = 18Private Const mcintMinMatchLen As Integer = 3Private Const mcintNull As Long = &H1000Private Const mcstrSignature As String = "FMZ"Private Declare Sub CopyMemory Lib "Kernel32" Alias "RtlMoveMemory" (pDest As Any, pSou rce As Any, ByVal dwLength As Long)Public Sub BeginProcss()If m_bCompress ThenCompressElseDecompressEnd IfEnd SubPrivate Function LastError(ErrNo As Integer) As StringSelect Case ErrNoCase 1LastError = "待压缩文件未设置或不存在"Case 2LastError = "待压缩文件长度太小"Case 3LastError = "待压缩文件已经过压缩"Case 4LastError = "待解压文件未设置或不存在"Case 5LastError = "待解压文件格式不对或为本软件不能认别的高版本软件所压缩" Case 254LastError = "用户取消了操作"Case 255LastError = "未知错误"End SelectEnd FunctionPublic Property Get CompressLevel() As IntegerCompressLevel = mintCompressLevel \ 16End PropertyPublic Property Let CompressLevel(ByVal intValue As Integer)mintCompressLevel = intValue * 16If mintCompressLevel < 0 Then mintCompressLevel = 0End PropertyPublic Property Get IsCompress() As BooleanIsCompress = m_bCompressEnd PropertyPublic Property Let IsCompress(ByVal bValue As Boolean)m_bCompress = bValueEnd PropertyPublic Property Let CancelProcss(ByVal bValue As Boolean)m_bEnableProcss = Not bV alueEnd PropertyPublic Property Get InputFileName() As StringInputFileName = m_strInputFileNameEnd PropertyPublic Property Get OutputFileName() As StringOutputFileName = m_strOutputFileNameEnd PropertyPublic Property Let OutputFileName(ByVal strValue As String) m_strOutputFileName = strValueEnd PropertyPublic Property Let InputFileName(ByVal strValue As String) m_strInputFileName = strValueEnd PropertyPrivate Sub Class_Terminate()m_bEnableProcss = FalseEnd SubPrivate Sub Form_Load()Set ObjZip = New ClassZip= "压缩"= "解压"= "中断"End SubPrivate Sub Form_Unload(Cancel As Integer)Set ObjZip = NothingEnd SubPrivate Sub ObjZip_FileProgress(sngPercentage As Single)Label1 = Int(sngPercentage * 100) & "%"End SubPrivate Sub ObjZip_ProcssError(ErrorDescription As String) MsgBox ErrorDescriptionEnd Sub'ClassZip类中的声明与属性、方法、事件Option ExplicitPublic Event FileProgress(sngPercentage As Single)Public Event ProcssError(ErrorDescription As String)Private Type FileHeaderHeaderTag As String * 3HeaderSize As IntegerFlag As ByteFileLength As LongVersion As IntegerEnd TypePrivate mintCompressLevel As LongPrivate m_bEnableProcss As BooleanPrivate m_bCompress As BooleanPrivate m_strInputFileName As StringPrivate m_strOutputFileName As StringPrivate Const mcintWindowSize As Integer = &H1000Private Const mcintMaxMatchLen As Integer = 18Private Const mcintMinMatchLen As Integer = 3Private Const mcintNull As Long = &H1000Private Const mcstrSignature As String = "FMZ"Private Declare Sub CopyMemory Lib "Kernel32" Alias "RtlMoveMemory" (pDest As Any, pSou rce As Any, ByVal dwLength As Long)Public Sub BeginProcss()If m_bCompress ThenCompressElseDecompressEnd IfEnd SubPrivate Function LastError(ErrNo As Integer) As StringSelect Case ErrNoCase 1LastError = "待压缩文件未设置或不存在"Case 2LastError = "待压缩文件长度太小"Case 3LastError = "待压缩文件已经过压缩"Case 4LastError = "待解压文件未设置或不存在"Case 5LastError = "待解压文件格式不对或为本软件不能认别的高版本软件所压缩"Case 254LastError = "用户取消了操作"Case 255LastError = "未知错误"End SelectEnd FunctionPublic Property Get CompressLevel() As IntegerCompressLevel = mintCompressLevel \ 16End PropertyPublic Property Let CompressLevel(ByVal intValue As Integer)mintCompressLevel = intValue * 16If mintCompressLevel < 0 Then mintCompressLevel = 0End PropertyPublic Property Get IsCompress() As BooleanIsCompress = m_bCompressEnd PropertyPublic Property Let IsCompress(ByVal bValue As Boolean)m_bCompress = bValueEnd PropertyPublic Property Let CancelProcss(ByVal bValue As Boolean) m_bEnableProcss = Not bV alueEnd PropertyPublic Property Get InputFileName() As StringInputFileName = m_strInputFileNameEnd PropertyPublic Property Get OutputFileName() As StringOutputFileName = m_strOutputFileNameEnd PropertyPublic Property Let OutputFileName(ByVal strValue As String) m_strOutputFileName = strValueEnd PropertyPublic Property Let InputFileName(ByVal strValue As String) m_strInputFileName = strValueEnd PropertyPrivate Sub Class_Terminate()m_bEnableProcss = FalseEnd Sub。
VB制作压缩解压程序和文本导入导出
导出：exec master..xp_cmdshell 'bcp "库名..表名" out "d:\tt.txt" -c -t ,-U sa -P password'导入：BULK INSERT 库名..表名FROM 'c:\test.txt'WITH (FIELDTERMINATOR = ',',ROWTERMINATOR = '\n')VB导出：'工程-〉引用ms active data object lib 2.xDim cn As New ADODB.ConnectionDim rs As New RecordsetPrivate Sub Form_Load()Dim str As Stringcn.ConnectionString = "Provider=sqloledb;Data Source=127.0.0.1;Initial Catalog=pubs;User Id=sa;P assword=lyjlee;"cn.Openrs.Open "authors", cn, adOpenKeyset, adLockOptimisticIf Not rs.EOF ThenOpen "c:\out.txt" For Output As #1Do While Not rs.EOFstr = rs("au_id") & "," & rs("au_lname")Print #1, strrs.MoveNextLoopEnd IfEnd Sub'数据库与文本文件的导入导出Private Sub Form_Load()Dim cn As New ADODB.ConnectionIf cn.State = 1 Thencn.CloseEnd Ifcn.CursorLocation = adUseClientcn.ConnectionString = "Provider=SQLOLEDB.1;Persist Security Info=False;User ID=sa;pwd=;Initial Catalog=学生;Data Source=MyServer"cn.Open'导出cn.Execute "SELECT * into [Text;HDR=YES;DATABASE=d:\].a.txt from students"'导入cn.Execute "insert into students select * from [Text;HDR=YES;DATABASE=d:\].a.txt"End Sub'数据库与文本文件的导入导出Dim cn As New ADODB.ConnectionIf cn.State = 1 Thencn.CloseEnd Ifcn.CursorLocation = adUseClientcn.ConnectionString = "Provider=SQLOLEDB.1;Persist Security Info=False;User ID=sa;pwd=password;Initial Catalog=d bname;Data Source=servername"cn.Open' 导出文本文件cn.Execute "EXEC master..xp_cmdshell 'bcp dbname..tablename out c:\DT.txt -c -Sservername -Usa -Ppassword '"' 文本文件导入数据库cn.Execute "EXEC master..xp_cmdshell 'bcp dbname..tablename in c:\DT.txt -c -Sservername -Usa -Ppassword' "’//加密程序SoureFileName=App.Path+"liu.txt" ‘//原文件DesFileName App.PaPth +"zhang.txt" '//加密后的文件Dim PassWord as StringDim PassLength as IntegerPassWord="123" '//密码Dim Buff1 as String, Buff2 as StringDim Ch1 as String,Ch2 as StringPassLength=Len(Password)Open SoureFileName for Input As #1Open DesFileName for output as #2While Not Eof(1)Buff1=Input(PassLength, #1)for i=1 to PassLengthCh1=Mid$(Buff,1,i)Ch2=Mid$(PassWord,1,i)Ch1=Chr(Asc(Ch1) Xor Asc(Ch2)+ 10 )Buff2=Buff2+Ch1Print #2,Buff2NextWendClose #1Close #2’//解密程序Dim SoureFileName As StringDim DesFileName as StringSoureFileName=App.Path+ “zhang.txt" ‘//加密后的文件DesFileName= App.PaPth +"liu.txt" '//原文件Dim PassWord as StringDim PassLength as IntegerPassWord="123" '//密码Dim Buff1 as String, Buff2 as StringDim Ch1 as String,Ch2 as StringPassLength=Len(Password)Open SoureFileName for Input As #1Open DesFileName for output as #2While Not Eof(1)Buff1=Input(PassLength, #1)for i=1 to PassLengthCh1=Mid$(Buff,1,i)Ch2=Mid$(PassWord,1,i)Ch1= chr( (Asc(Ch1)-10) Xor Asc(Ch2))Buff2=Buff2+Ch1Print #2,Buff2NextWendClose #1Close #2Dim s As StringOpen "e:\test.txt" For Input As #1While Not EOF(1)Input #1, sMsgBox s 'S就是每个字段的值,你可以换成数据库中的字段就行了 WendClose #1VB实现压缩和解压：Private Sub Command1_Click()Dim wzipexe As String ' winzip 执行文件的位置Dim wsource As String ' 原始文件(压缩前)Dim wtarget As String ' 目地文件(压缩后)Dim wcmd As String ' Shell 指令Dim retval As Double ' Shell 指令传回值' Shell 指令wzipexe = "C:\program files\winzip\WINzip32" ' winzip 执行文件的位置wtarget = Text2.Text ' 目地文件(压缩后)wsource = Text1.Text ' 原始文件(压缩前)wcmd = wzipexe & " -a " & wtarget & " " & wsourceretval = Shell(wcmd, 6)End Sub关于WinRar的用法主要介绍以下如何在WinRar中用命令行来压缩和解压缩文件。
VB中怎样实现资源文件(.RES)的创建和调用
所谓资源文件，就是指将在程序运行时用到的资源集中在一起的一个文件。一个资源文件可以包括文字（TEXT）、位图（BITMAP）。图标（ICON）等。并且在程序中调用时不用指明路径，这就简化了程序的编写并减少了发生错误的可能。现在我就以一个小程序为例讲述资源文件的一些使用方法。
这个工程运行后，当点击【未来】按钮时中间图像将依次变换为夏、秋、冬、春……点击【从前】按钮则以相反顺序转动图片（源程序附后）。
详细信息 请参阅相应函数主题。
免费领取CSDN积分大礼包对我有用[0] 丢个板砖[0] 引用 | 举报 | 管理
dbcontrols
dbcontrols
等级：
29
#3 得分：10 回复于： 2002-01-28 12:40:13
VB编程的好帮手--资源文件
各位VB高手，你一定也常常因苦于无法组织自己程序中大量的picture，而头痛不已，那就让小生为各位介绍一下VB编程的好帮手--资源文件。
Dim iid As Integer
并初始化img和iid：
img.Picture=LoadResPicture(100,vbResBitmap)
iid=100
其中LoadResPicture(id,model)为从资源文件中调用图像的函数，100表示ID号为100的项，vbResBitmap为一常量，值为0，表示以位图方式打开。然后在两个Command控件中加入源程序代码。
要将新资源文件添加到您的工程中，请按照以下步骤执行：
从“工具”菜单中选择“资源编辑器”，将在资源编辑器窗口打开一个空的资源文件。
注意 必须安装资源编辑器外接程序。有关安装外接程序的信息，请参阅“管理工程”中的“使用向导和外接程序”。
VB调用EXE文件
VB调用EXE文件VB 调用EXE文件一、调用方法有三种方法 :)ShellExecute函数WinExec函数Shell函数1.ShellExecuteVB声明Declare Function ShellExecute Lib "shell32.dll " Alias "ShellExecuteA " (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long 说明查找与指定文件关联在一起的程序的文件名返回值Long，非零表示成功，零表示失败。
会设置GetLastError[参数表]参数类型及说明hwnd Long，指定一个窗口的句柄，有时候，windows程序有必要在创建自己的主窗口前显示一个消息框lpOperation String，指定字串“open”来打开lpFlie文档，或指定“Print”来打印它lpFile String，想用关联程序打印或打开一个程序名或文件名lpParameters String，如lpszFlie是可执行文件，则这个字串包含传递给执行程序的参数lpDirectory String，想使用的完整路径nShowCmd Long，定义了如何显示启动程序的常数值。
参考ShowWindow函数的nCmdShow参数2.WinExecVB声明Declare Function WinExec Lib "kernel32 " Alias "WinExec " (ByVal lpCmdLine As String, ByVal nCmdShow As Long) As Long 说明运行指定的程序返回值Long，大于32表示成功，请参考FindExecutable函数[参数表]参数类型及说明lpCmdLine String，包含要执行的命令行nCmdShow Long，定义了以怎样的形式启动程序的常数值。
VB制作可输出函数DLLrar自解压去右键DLL源代码.doc
VB制作可输出函数DLL （标准DLL ）无需注册，只要放在程序同目录内就可以调用，非常方便。
其实可用的方法有很多种，下面介绍的这个是我用到现在最可靠的的，里面的C2.EXE和link.exe ,因为时间长了记不得是那个作者的了 ,忘作者见谅。
第一步、准备工作1、编译新的 C2.EXE,和 link.exeo&************新的 C2 EXE**********************************新的C2.exe程序建立新工程，不需要窗体，只要一个模块放上下面的main过程，工程属性里面启动对象Sub mainPublic Sub Main()On Error Resume NextDim strCmd As String, strPath As StringDim oFS As New Scripting. FileSystemObjectDim ts As TextStreamstrCmd = CommandstrPath = App.PathSet ts = oFS. CreateTextFile(strPath & "2/og.F"丿ts. Write Line ''Beginning execution at " & Date & ” " & Time()ts. WriteBlankLines 1ts. WriteLiriw "Command line parameters to c2 call:nts.WriteLine " " & strCmdts. WriteBlankLines 1ts. WriteLine "Calling C2 compiler"Shell n c2comp.exe n & strCmdIf Err.Number <> 0 Thents. Write Line "Error in calling C2 compiler..."End If6************新白勺ts. WriteBlankLines 1ts. Write Line "Returned from c2 compiler call 9' ts.CloseEnd Sub编译成C2.EXE,不要直接覆盖，放在其他地方备用。
使用VB6操作WinRAR(VB6源代码)
使用Visual Basic 6.0 控制WinRAR进行压缩或解压等操作(1)命令行语法:--------------------------------------------------------------------------------从命令行也可以运行WinRAR 命令，常规的命令行语法描述如下:WinRAR <命令> -<开关1> -<开关N><压缩文件><文件...><@列表文件...><解压路径\>a) 如果未指定文件或是列表文件时，WinRAR 将会以缺省的*.* 运行全部的文件;b) 如果未指定压缩文件扩展名时，WinRAR 将会使用在压缩配置中选定的默认压缩文件格式。
但你可以指定.RAR 或.ZIP 扩展名来替换它们;c) 在命令行所输入的开关会替换相同的配置设置值;d) 在命令c 、e、s、t、rr、k 和x 可在压缩文件名中使用通配符。
如此可以用单个的命令来进行超过一个以上的压缩文件，除此之外，如果你指定-r 开关于这些命令时，它们将会搜索在子文件夹中的压缩文件;e) 某些命令和开关只应用在RAR 压缩文件，有些则在RAR 和ZIP 都可使用，而某些则可应用在全部的压缩文件格式。
这一些都得看压缩文件格式所提供的特性而定;f) 命令和开关的大小写是相同意思的，你可以用大写或者小写来下命令均可;g)你可以在命令行中同时指定普通的文件名和列表文件名;h)解压路径只与命令e 和x ，搭配使用。
指出解压文件添加的位置。
如果文件夹不存在时，会自动创建。
(2)字母命令列表(3)详解各个命令：--------------------------------------------------------------------------------命令 A - 添加文件到压缩文件添加指定的文件和文件夹到压缩文件中。
用VB轻松调用其他程序
用VB轻松调用其他程序我们编写程序时，有时会遇到在一个程序中调用并控制另一个程序执行的情况，在一些编程语言中实现起来较为繁琐，但如果用VB编写时，则可轻松实现。
下面我就以在程序中调用“计算器”为例，总结了以下几种方法：一、以异步方式来执行其他程序Shell 函数是以异步方式来调用其他程序的。
也就是说，用Shell启动的程序可能还没有完成执行过程，就已经执行到Shell 函数之后的语句。
语法：Shell(pathname[,windowstyle])说明：pathname：必要参数。
Variant (String)，要执行的程序名，以及任何必需的参数或命令行变量，可能还包括目录或文件夹，以及驱动器。
例如：RetVal = Shell(″C:\WINDOWS\CALC.EXE″, 1) ′调用计算器。
二、以同步方式来执行其他程序有时候，我们需要让VB在执行完外部程序后再执行下一语句，这就需要使用API函数。
我们可通过OpenProcess和CloseHandle函数来检测调用软件的运行情况。
这两个函数的声明如下：Declare Function OpenProcess Lib ″kernel32″Alias ″OpenProcess″(ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As LongDeclare Function CloseHandle Lib ″kernel32″Alias ″CloseHandle″(ByVal hObject As Long) As Long建立下面函数，用以判断程序是否在运行，如果是，则在运行时返回True。
Function IsRunning(ByVal ProgramID) As Boolean′传入进程标识IDDim hProgram As Long′被检测的程序进程句柄hProgram=OpenProcess(0,False,ProgramID)If Not hProgram=0 ThenIsRunning=TrueElseIsRunning=FalseEnd IfCloseHandle hProgramEnd Function例如要调用计算器(CALC.EXE)并等到它运行完成后再执行下一语句，可以使用以下代码：Dim RetValMsgBox ″开始运行″RetVal = Shell(″C:\WINDOWS\CALC.EXE″, 1)While IsRunning(RetVal)DoEventsWendMsgBox ″结束运行″三、关闭正在运行中的其他软件如果要在程序中关闭正在运行中的其他程序，可以先使用FindWindow函数找出相应的程序句柄，然后调用PostMessage函数关闭该程序即可。
- 1、下载文档前请自行甄别文档内容的完整性，平台不提供额外的编辑、内容补充、找答案等附加服务。
- 2、"仅部分预览"的文档,不可在线预览部分如存在完整性等问题,可反馈申请退款(可完整预览的文档不适用该条件!)。
- 3、如文档侵犯您的权益，请联系客服反馈,我们会尽快为您处理(人工客服工作时间：9:00-18:30)。
与WinRAR以最快方式压缩ZIP比较，255M的文件Level=0时用时24.98秒大小95.1MLevel=255时用时30.24秒大小91.6MWinRAR最快压缩ZIP 用时 25.2秒大小58.6M标准RAR压缩，我看了一下，实在太慢，也就没试了，估计要几分钟才会有结果。
从速度看，基本持平了，这个算法虽然最大压缩能力有限，但感觉设计得很巧妙，每次都基于动态表，使软件可以做得很小巧，资源占用也很少。
非常值得收藏！'测试窗体中的代码Option ExplicitPrivate WithEvents ObjZip As ClassZipPrivate BgTime As SinglePrivate Sub Command1_Click()BgTime = TimerCommand1.Enabled = FalseCommand2.Enabled = FalseWith ObjZip.InputFileName = Text1.Text.OutputFileName = Text2.Text.IsCompress = True.CompressLevel = Val(Text4.Text).BeginProcssEnd WithLabel1.Caption = Round(Timer - BgTime, 2) & "秒"Command1.Enabled = TrueCommand2.Enabled = TrueEnd SubPrivate Sub Command2_Click()BgTime = TimerCommand1.Enabled = FalseCommand2.Enabled = FalseWith ObjZip.InputFileName = Text2.Text.OutputFileName = Text3.Text.IsCompress = False.BeginProcssEnd WithLabel1 = Round(Timer - BgTime, 2) & "秒"Command1.Enabled = TrueCommand2.Enabled = TrueEnd SubPrivate Sub Command3_Click()ObjZip.CancelProcss = TrueEnd SubPrivate Sub Form_Load()Set ObjZip = New ClassZipCommand1.Caption = "压缩"Command2.Caption = "解压"Command3.Caption = "中断"End SubPrivate Sub Form_Unload(Cancel As Integer)Set ObjZip = NothingEnd SubPrivate Sub ObjZip_FileProgress(sngPercentage As Single) Label1 = Int(sngPercentage * 100) & "%"End SubPrivate Sub ObjZip_ProcssError(ErrorDescription As String) MsgBox ErrorDescriptionEnd Sub'ClassZip类中的声明与属性、方法、事件Option ExplicitPublic Event FileProgress(sngPercentage As Single)Public Event ProcssError(ErrorDescription As String) Private Type FileHeaderHeaderTag As String * 3HeaderSize As IntegerFlag As ByteFileLength As LongVersion As IntegerEnd TypePrivate mintCompressLevel As LongPrivate m_bEnableProcss As BooleanPrivate m_bCompress As BooleanPrivate m_strInputFileName As StringPrivate m_strOutputFileName As StringPrivate Const mcintWindowSize As Integer = &H1000 Private Const mcintMaxMatchLen As Integer = 18Private Const mcintMinMatchLen As Integer = 3Private Const mcintNull As Long = &H1000Private Const mcstrSignature As String = "FMZ"Private Declare Sub CopyMemory Lib "Kernel32" Alias "RtlMoveMemory" (pDest As Any, pSou rce As Any, ByVal dwLength As Long)Public Sub BeginProcss()If m_bCompress ThenCompressElseDecompressEnd IfEnd SubPrivate Function LastError(ErrNo As Integer) As StringSelect Case ErrNoCase 1LastError = "待压缩文件未设置或不存在"Case 2LastError = "待压缩文件长度太小"Case 3LastError = "待压缩文件已经过压缩"Case 4LastError = "待解压文件未设置或不存在"Case 5LastError = "待解压文件格式不对或为本软件不能认别的高版本软件所压缩"Case 254LastError = "用户取消了操作"Case 255LastError = "未知错误"End SelectEnd FunctionPublic Property Get CompressLevel() As IntegerCompressLevel = mintCompressLevel \ 16End PropertyPublic Property Let CompressLevel(ByVal intValue As Integer)mintCompressLevel = intValue * 16If mintCompressLevel < 0 Then mintCompressLevel = 0End PropertyPublic Property Get IsCompress() As BooleanIsCompress = m_bCompressEnd PropertyPublic Property Let IsCompress(ByVal bValue As Boolean)m_bCompress = bValueEnd PropertyPublic Property Let CancelProcss(ByVal bValue As Boolean)m_bEnableProcss = Not bV alueEnd PropertyPublic Property Get InputFileName() As StringInputFileName = m_strInputFileNameEnd PropertyPublic Property Get OutputFileName() As StringOutputFileName = m_strOutputFileNameEnd PropertyPublic Property Let OutputFileName(ByVal strValue As String)m_strOutputFileName = strValueEnd PropertyPublic Property Let InputFileName(ByVal strValue As String)m_strInputFileName = strValueEnd PropertyPrivate Sub Class_Terminate()m_bEnableProcss = FalseEnd SubPrivate Sub Compress()Dim lngTemp As Long, intCount As IntegerDim intBufferLocation As IntegerDim intMaxLen As IntegerDim intNext As IntegerDim intPrev As IntegerDim intMatchPos As IntegerDim intMatchLen As IntegerDim intInputFile As IntegerDim intOutputFile As IntegerDim aintWindowNext(mcintWindowSize + 1 + mcintWindowSize) As IntegerDim aintWindowPrev(mcintWindowSize + 1) As IntegerDim intByteCodeWritten As LongDim intBitCount As IntegerDim abytWindow(mcintWindowSize + mcintMaxMatchLen) As ByteDim udtFileH As FileHeaderDim strOutTmpFile As StringDim lngBytesRead As LongDim lngFileLength As LongDim lngCurWritten As LongDim lngInBufLen As Long, abytInputBuffer() As Byte, abytOutputBuffer() As ByteDim lngOutBufLen As Long, lngInPos As Long, lngOutPos As LongDim intErrNo As IntegerOn Error GoTo PROC_ERRm_bEnableProcss = TrueIf Len(Dir(m_strInputFileName)) = 0 Or Len(m_strInputFileName) = 0 Then intErrNo = 1: GoToPROC_ERRIf Len(m_strOutputFileName) = 0 Then m_strOutputFileName = m_strInputFileNamestrOutTmpFile = m_strOutputFileName & ".tmp"If Len(Dir(strOutTmpFile)) > 0 Then Kill strOutTmpFileIf FileLen(m_strInputFileName) < 100 Then intErrNo = 2: GoTo PROC_ERRintInputFile = FreeFileOpen m_strInputFileName For Binary Access Read As intInputFileGet intInputFile, , udtFileHSeek #intInputFile, 1If udtFileH.HeaderTag = mcstrSignature Then intErrNo = 3: GoTo PROC_ERRintOutputFile = FreeFileOpen strOutTmpFile For Binary As intOutputFileFor intCount = 0 To mcintWindowSizeaintWindowPrev(intCount) = mcintNullabytWindow(intCount) = &H20NextCopyMemory aintWindowNext(0), aintWindowPrev(0), (mcintWindowSize + 1) * 2CopyMemory aintWindowNext(mcintWindowSize + 1), aintWindowPrev(0), mcintWindowSize * 2CopyMemory abytWindow(mcintWindowSize + 1), abytWindow(0), mcintMaxMatchLen - 1 intByteCodeWritten = 1lngFileLength = LOF(intInputFile)lngInBufLen = &HA000&lngOutBufLen = &HA000&If lngInBufLen > lngFileLength Then lngInBufLen = lngFileLengthReDim abytInputBuffer(lngInBufLen - 1)ReDim abytOutputBuffer(lngOutBufLen + 17)With udtFileH.HeaderSize = Len(udtFileH)lngCurWritten = .HeaderSize + 1.HeaderTag = mcstrSignature.FileLength = lngFileLength.Version = App.Revision.Flag = 0End WithintMaxLen = mcintMaxMatchLenlngBytesRead = mcintMaxMatchLenlngInPos = mcintMaxMatchLenintBitCount = 1Put intOutputFile, , udtFileHGet intInputFile, , abytInputBufferCopyMemory abytWindow(0), abytInputBuffer(0), mcintMaxMatchLenCopyMemory abytWindow(mcintWindowSize), abytInputBuffer(0), mcintMaxMatchLenDo While intMaxLenintMatchPos = 0intMatchLen = 0intPrev = aintWindowNext(((&H100& * abytWindow(intBufferLocation + 1) + abytWindow(int BufferLocation)) And &HFFF) + mcintWindowSize + 1)intCount = 0Do Until intCount > mintCompressLevel Or intPrev = mcintNullintNext = 0Do While (abytWindow(intPrev + intNext) = abytWindow(intBufferLocation + intNext)) And int Next < mcintMaxMatchLenintNext = intNext + 1LoopIf intNext > intMatchLen ThenintMatchLen = intNextintMatchPos = intPrevIf intNext = mcintMaxMatchLen ThenaintWindowNext(aintWindowPrev(intPrev)) = aintWindowNext(intPrev)aintWindowPrev(aintWindowNext(intPrev)) = aintWindowPrev(intPrev)aintWindowNext(intPrev) = mcintNullaintWindowPrev(intPrev) = mcintNullExit DoEnd IfEnd IfintPrev = aintWindowNext(intPrev)intCount = intCount + 1LoopIf intBitCount And &H100 ThenlngOutPos = intByteCodeWrittenIf intByteCodeWritten > lngOutBufLen ThenPut intOutputFile, lngCurWritten, abytOutputBufferDoEventsIf m_bEnableProcss = False Then intErrNo = 254: GoTo PROC_ERRlngCurWritten = lngCurWritten + intByteCodeWrittenlngOutPos = 0End IfintByteCodeWritten = lngOutPos + 1intBitCount = 1abytOutputBuffer(lngOutPos) = 0End IfIf intMatchLen < mcintMinMatchLen ThenintMatchLen = 1abytOutputBuffer(intByteCodeWritten) = abytWindow(intBufferLocation)abytOutputBuffer(lngOutPos) = abytOutputBuffer(lngOutPos) Or intBitCountEnd IfIf intMatchLen > 1 ThenIf intMatchLen > intMaxLen Then intMatchLen = intMaxLenabytOutputBuffer(intByteCodeWritten) = intMatchPos And &HFFintByteCodeWritten = intByteCodeWritten + 1abytOutputBuffer(intByteCodeWritten) = (((intMatchPos \ 16) And &HF0) Or intMatchLen - mci ntMinMatchLen) And &HFFEnd IfintByteCodeWritten = intByteCodeWritten + 1intBitCount = intBitCount * 2Do While intMatchLenintPrev = intBufferLocation + mcintMaxMatchLenintNext = intPrev And &HFFFIf aintWindowPrev(intNext) <> mcintNull ThenaintWindowNext(aintWindowPrev(intNext)) = aintWindowNext(intNext)aintWindowPrev(aintWindowNext(intNext)) = aintWindowPrev(intNext)aintWindowNext(intNext) = mcintNullaintWindowPrev(intNext) = mcintNullEnd IfIf lngInPos < lngInBufLen ThenabytWindow(intNext) = abytInputBuffer(lngInPos)If intPrev >= mcintWindowSize Then abytWindow(intPrev) = abytInputBuffer(lngInPos)lngBytesRead = lngBytesRead + 1lngInPos = lngInPos + 1If lngInPos >= lngInBufLen ThenIf lngFileLength > lngBytesRead ThenIf lngInBufLen > lngFileLength - lngBytesRead ThenlngInBufLen = lngFileLength - lngBytesReadReDim abytInputBuffer(lngInBufLen - 1)End IfGet intInputFile, , abytInputBufferlngInPos = 0RaiseEvent FileProgress(lngBytesRead / lngFileLength)DoEventsIf m_bEnableProcss = False Then intErrNo = 254: GoTo PROC_ERREnd IfEnd IfEnd IfintPrev = ((&H100& * abytWindow(intBufferLocation + 1) + abytWindow(intBufferLocation)) A nd &HFFF) + mcintWindowSize + 1intNext = aintWindowNext(intPrev)aintWindowPrev(intBufferLocation) = intPrevaintWindowNext(intBufferLocation) = intNextaintWindowNext(intPrev) = intBufferLocationIf intNext <> mcintNull Then aintWindowPrev(intNext) = intBufferLocationintBufferLocation = (intBufferLocation + 1) And &HFFFintMatchLen = intMatchLen - 1LoopIf lngInPos >= lngInBufLen Then intMaxLen = intMaxLen - 1LoopIf intByteCodeWritten > 0 ThenReDim Preserve abytOutputBuffer(intByteCodeWritten - 1)Put intOutputFile, lngCurWritten, abytOutputBufferEnd IfClose intInputFileClose intOutputFileIf Len(Dir(m_strOutputFileName)) > 0 Then Kill m_strOutputFileNameName strOutTmpFile As m_strOutputFileNameRaiseEvent FileProgress(1)Exit SubPROC_ERR:Close intOutputFileClose intInputFileIf Len(Dir(strOutTmpFile)) > 0 And Len(strOutTmpFile) > 0 Then Kill strOutTmpFileIf intErrNo = 0 Then intErrNo = 255RaiseEvent ProcssError(LastError(intErrNo))End SubPrivate Sub Decompress()Dim intTemp As IntegerDim intBufferLocation As IntegerDim intLength As IntegerDim bytHiByte As IntegerDim bytLoByte As IntegerDim intWindowPosition As IntegerDim lngFlags As LongDim intInputFile As IntegerDim intOutputFile As IntegerDim abytWindow(mcintWindowSize + mcintMaxMatchLen) As ByteDim strOutTmpFile As StringDim lngBytesRead As LongDim lngBytesWritten As LongDim lngFileLength As LongDim lngOriginalFileLen As LongDim lngInBufLen As Long, abytInBuf() As Byte, abytOutBuf() As ByteDim lngOutBufLen As Long, lngInPos As Long, lngOutPos As LongDim udtFileH As FileHeaderDim intErrNo As IntegerOn Error GoTo PROC_ERRm_bEnableProcss = TrueIf Len(Dir(m_strInputFileName)) = 0 Or Len(m_strInputFileName) = 0 Then intErrNo = 4: GoToPROC_ERRIf Len(m_strOutputFileName) = 0 Then m_strOutputFileName = m_strInputFileName strOutTmpFile = m_strOutputFileName & ".tmp"If Len(Dir(strOutTmpFile)) > 0 Then Kill strOutTmpFileintInputFile = FreeFileOpen m_strInputFileName For Binary Access Read As intInputFilelngFileLength = LOF(intInputFile)Get intInputFile, , udtFileHIf udtFileH.HeaderTag = mcstrSignature And udtFileH.V ersion <= App.Revision Then Seek #intInputFile, udtFileH.HeaderSize + 1intOutputFile = FreeFileOpen strOutTmpFile For Binary As intOutputFilelngOriginalFileLen = udtFileH.FileLengthlngFileLength = lngFileLength - udtFileH.HeaderSizelngInBufLen = &H20000lngOutBufLen = &H20000If lngInBufLen > lngFileLength Then lngInBufLen = lngFileLengthReDim abytInBuf(lngInBufLen - 1)ReDim abytOutBuf(lngOutBufLen - 1)Get intInputFile, , abytInBufDo While lngBytesWritten < lngOriginalFileLenlngFlags = lngFlags \ 2If (lngFlags And &H100) = 0 ThenlngFlags = &HFF00& Or abytInBuf(lngInPos)lngBytesRead = lngBytesRead + 1lngInPos = lngInPos + 1If lngInPos >= lngInBufLen ThenIf lngFileLength > lngBytesRead ThenIf lngInBufLen > lngFileLength - lngBytesRead ThenlngInBufLen = lngFileLength - lngBytesReadReDim abytInBuf(lngInBufLen - 1)End IfGet intInputFile, , abytInBufDoEventsIf m_bEnableProcss = False Then intErrNo = 254: GoTo PROC_ERRlngInPos = 0End IfEnd IfEnd IfIf (lngFlags And 1) ThenabytWindow(intWindowPosition) = abytInBuf(lngInPos)abytOutBuf(lngOutPos) = abytInBuf(lngInPos)lngBytesRead = lngBytesRead + 1lngInPos = lngInPos + 1lngBytesWritten = lngBytesWritten + 1lngOutPos = lngOutPos + 1intWindowPosition = (intWindowPosition + 1) And &HFFFIf lngInPos >= lngInBufLen ThenIf lngFileLength > lngBytesRead ThenIf lngInBufLen > lngFileLength - lngBytesRead ThenlngInBufLen = lngFileLength - lngBytesReadReDim abytInBuf(lngInBufLen - 1)End IfGet intInputFile, , abytInBufDoEventsIf m_bEnableProcss = False Then intErrNo = 254: GoTo PROC_ERRlngInPos = 0End IfEnd IfIf lngOutPos >= lngOutBufLen ThenPut intOutputFile, , abytOutBuflngOutPos = 0RaiseEvent FileProgress(lngBytesWritten / lngOriginalFileLen)DoEventsIf m_bEnableProcss = False Then intErrNo = 254: GoTo PROC_ERREnd IfElsebytHiByte = abytInBuf(lngInPos)lngBytesRead = lngBytesRead + 1lngInPos = lngInPos + 1If lngInPos >= lngInBufLen ThenIf lngFileLength > lngBytesRead ThenIf lngInBufLen > lngFileLength - lngBytesRead ThenlngInBufLen = lngFileLength - lngBytesReadReDim abytInBuf(lngInBufLen - 1)End IfGet intInputFile, , abytInBufDoEventsIf m_bEnableProcss = False Then intErrNo = 254: GoTo PROC_ERRlngInPos = 0End IfEnd IfbytLoByte = abytInBuf(lngInPos)intBufferLocation = ((bytLoByte And &HF0) * 16 + bytHiByte) And &HFFF intLength = (bytLoByte And &HF) + mcintMinMatchLenlngBytesRead = lngBytesRead + 1lngInPos = lngInPos + 1If lngInPos >= lngInBufLen ThenIf lngFileLength > lngBytesRead ThenIf lngInBufLen > lngFileLength - lngBytesRead ThenlngInBufLen = lngFileLength - lngBytesReadReDim abytInBuf(lngInBufLen - 1)End IfGet intInputFile, , abytInBufDoEventsIf m_bEnableProcss = False Then intErrNo = 254: GoTo PROC_ERRlngInPos = 0End IfEnd IfintTemp = intBufferLocation + intLengthDo While intBufferLocation < intTempabytOutBuf(lngOutPos) = abytWindow((intBufferLocation) And &HFFF) abytWindow(intWindowPosition) = abytOutBuf(lngOutPos)intBufferLocation = intBufferLocation + 1lngBytesWritten = lngBytesWritten + 1intWindowPosition = (intWindowPosition + 1) And &HFFFlngOutPos = lngOutPos + 1If lngOutPos >= lngOutBufLen ThenPut intOutputFile, , abytOutBuflngOutPos = 0RaiseEvent FileProgress(lngBytesWritten / lngOriginalFileLen)DoEventsIf m_bEnableProcss = False Then intErrNo = 254: GoTo PROC_ERREnd IfLoopEnd IfLoopIf lngOutPos > 0 ThenReDim Preserve abytOutBuf(lngOutPos - 1)Put intOutputFile, , abytOutBufEnd IfClose intOutputFileElseintErrNo = 5GoTo PROC_ERREnd IfClose intInputFileIf Len(Dir(m_strOutputFileName)) > 0 Then Kill m_strOutputFileName Name strOutTmpFile As m_strOutputFileNameRaiseEvent FileProgress(1)Exit SubPROC_ERR:Close intOutputFileClose intInputFileIf Len(Dir(strOutTmpFile)) > 0 And Len(strOutTmpFile) > 0 Then Kill strOutTmpFileIf intErrNo = 0 Then intErrNo = 255RaiseEvent ProcssError(LastError(intErrNo))End Sub'ClassZip类中的声明与属性、方法、事件Option ExplicitPublic Event FileProgress(sngPercentage As Single)Public Event ProcssError(ErrorDescription As String)Private Type FileHeaderHeaderTag As String * 3HeaderSize As IntegerFlag As ByteFileLength As LongVersion As IntegerEnd TypePrivate mintCompressLevel As LongPrivate m_bEnableProcss As BooleanPrivate m_bCompress As BooleanPrivate m_strInputFileName As StringPrivate m_strOutputFileName As StringPrivate Const mcintWindowSize As Integer = &H1000Private Const mcintMaxMatchLen As Integer = 18Private Const mcintMinMatchLen As Integer = 3Private Const mcintNull As Long = &H1000Private Const mcstrSignature As String = "FMZ"Private Declare Sub CopyMemory Lib "Kernel32" Alias "RtlMoveMemory" (pDest As Any, pSou rce As Any, ByVal dwLength As Long)Public Sub BeginProcss()If m_bCompress ThenCompressElseDecompressEnd IfEnd SubPrivate Function LastError(ErrNo As Integer) As StringSelect Case ErrNoCase 1LastError = "待压缩文件未设置或不存在"Case 2LastError = "待压缩文件长度太小"Case 3LastError = "待压缩文件已经过压缩"Case 4LastError = "待解压文件未设置或不存在"Case 5LastError = "待解压文件格式不对或为本软件不能认别的高版本软件所压缩" Case 254LastError = "用户取消了操作"Case 255LastError = "未知错误"End SelectEnd FunctionPublic Property Get CompressLevel() As IntegerCompressLevel = mintCompressLevel \ 16End PropertyPublic Property Let CompressLevel(ByVal intValue As Integer)mintCompressLevel = intValue * 16If mintCompressLevel < 0 Then mintCompressLevel = 0End PropertyPublic Property Get IsCompress() As BooleanIsCompress = m_bCompressEnd PropertyPublic Property Let IsCompress(ByVal bValue As Boolean)m_bCompress = bValueEnd PropertyPublic Property Let CancelProcss(ByVal bValue As Boolean)m_bEnableProcss = Not bV alueEnd PropertyPublic Property Get InputFileName() As StringInputFileName = m_strInputFileNameEnd PropertyPublic Property Get OutputFileName() As StringOutputFileName = m_strOutputFileNameEnd PropertyPublic Property Let OutputFileName(ByVal strValue As String)m_strOutputFileName = strValueEnd PropertyPublic Property Let InputFileName(ByVal strValue As String)m_strInputFileName = strValueEnd PropertyPrivate Sub Class_Terminate()m_bEnableProcss = FalseEnd SubPrivate Sub Form_Load()Set ObjZip = New ClassZipCommand1.Caption = "压缩"Command2.Caption = "解压"Command3.Caption = "中断"End SubPrivate Sub Form_Unload(Cancel As Integer)Set ObjZip = NothingEnd SubPrivate Sub ObjZip_FileProgress(sngPercentage As Single) Label1 = Int(sngPercentage * 100) & "%"End SubPrivate Sub ObjZip_ProcssError(ErrorDescription As String) MsgBox ErrorDescriptionEnd Sub'ClassZip类中的声明与属性、方法、事件Option ExplicitPublic Event FileProgress(sngPercentage As Single)Public Event ProcssError(ErrorDescription As String) Private Type FileHeaderHeaderTag As String * 3HeaderSize As IntegerFlag As ByteFileLength As LongVersion As IntegerEnd TypePrivate mintCompressLevel As LongPrivate m_bEnableProcss As BooleanPrivate m_bCompress As BooleanPrivate m_strInputFileName As StringPrivate m_strOutputFileName As StringPrivate Const mcintWindowSize As Integer = &H1000 Private Const mcintMaxMatchLen As Integer = 18Private Const mcintMinMatchLen As Integer = 3Private Const mcintNull As Long = &H1000Private Const mcstrSignature As String = "FMZ"Private Declare Sub CopyMemory Lib "Kernel32" Alias "RtlMoveMemory" (pDest As Any, pSou rce As Any, ByVal dwLength As Long)Public Sub BeginProcss()If m_bCompress ThenCompressElseDecompressEnd IfEnd SubPrivate Function LastError(ErrNo As Integer) As StringSelect Case ErrNoCase 1LastError = "待压缩文件未设置或不存在"Case 2LastError = "待压缩文件长度太小"Case 3LastError = "待压缩文件已经过压缩"Case 4LastError = "待解压文件未设置或不存在"Case 5LastError = "待解压文件格式不对或为本软件不能认别的高版本软件所压缩"Case 254LastError = "用户取消了操作"Case 255LastError = "未知错误"End SelectEnd FunctionPublic Property Get CompressLevel() As IntegerCompressLevel = mintCompressLevel \ 16End PropertyPublic Property Let CompressLevel(ByVal intValue As Integer)mintCompressLevel = intValue * 16If mintCompressLevel < 0 Then mintCompressLevel = 0End PropertyPublic Property Get IsCompress() As BooleanIsCompress = m_bCompressEnd PropertyPublic Property Let IsCompress(ByVal bValue As Boolean)m_bCompress = bValueEnd PropertyPublic Property Let CancelProcss(ByVal bValue As Boolean)m_bEnableProcss = Not bV alueEnd PropertyPublic Property Get InputFileName() As StringInputFileName = m_strInputFileNameEnd PropertyPublic Property Get OutputFileName() As StringOutputFileName = m_strOutputFileNameEnd PropertyPublic Property Let OutputFileName(ByVal strValue As String) m_strOutputFileName = strValueEnd PropertyPublic Property Let InputFileName(ByVal strValue As String) m_strInputFileName = strValueEnd PropertyPrivate Sub Class_Terminate()m_bEnableProcss = FalseEnd Sub。