[VBA程序]：Compress Lisp Files

efan2000

Compress Lisp Files

2. 
   
3. [FONT=courier new]  
   
4. Option Explicit
   
5. Dim lngDataCount As Long
   
6. Dim lngBufferStart As Long
   
7. Dim lngMxBuffSize As Long
   
8. Dim strBuffer As String
   
9. Dim lngBuffOffset As Long
   
10. Dim lngBuffSize As Long
    
11. Dim strDatContrl As String
    
12. Dim bytDataCntrlChar As Byte
    
13. Dim lngCntr As Long
    
14. Dim bytCntrlPos As Byte
    
15. Dim lngCompLen As Long
    
16. Dim lngCompPos As Long
    
17. Dim lngBytCompLen As Long
    
18. Dim lngControlPos As Long
    
19. Dim bytCntrlBitPos As Byte
    
20. Dim lngDataPos As Long
    
21. Dim lngDecompStart As Long
    
22. Dim lngDecompLen As Long
    
23. 
    
24. Public Function LispCompress(strCompName As String) As String
    
25.     lngMxBuffSize = 55535
    
26.     lngBytCompLen = 255
    
27.     lngBufferStart = 0
    
28.     strDatContrl = ""
    
29.     bytDataCntrlChar = 0
    
30.     bytCntrlPos = 0
    
31.     lngCntr = 0
    
32.     If Len(strCompName) > 4 Then
    
33.         LispCompress = Left(strCompName, 4)
    
34.         For lngDataCount = 5 To Len(strCompName)
    
35.             If lngDataCount > lngMxBuffSize Then
    
36.                 lngBuffSize = lngMxBuffSize
    
37.                 lngBufferStart = lngDataCount - lngMxBuffSize
    
38.             Else
    
39.                 lngBuffSize = lngDataCount - 1
    
40.                 lngBufferStart = 1
    
41.             End If
    
42. 
    
43.             strBuffer = Mid(strCompName, lngBufferStart, lngBuffSize)
    
44.             If Len(strCompName) - lngDataCount < lngBytCompLen Then lngBytCompLen = Len(strCompName) - lngDataCount
    
45.             lngCompPos = 0
    
46.             For lngCompLen = 3 To lngBytCompLen Step 3
    
47.                 If lngCompLen > lngBytCompLen Then
    
48.                     lngCompLen = lngBytCompLen
    
49.                 End If
    
50.                 lngCompPos = InStr(1, strBuffer, Mid(strCompName, lngDataCount, lngCompLen), 0)
    
51.                 If lngCompPos = 0 Then
    
52.                     If lngCompLen > 3 Then
    
53.                         While lngCompPos = 0
    
54.                             lngCompPos = InStr(1, strBuffer, Mid(strCompName, lngDataCount, lngCompLen - 1), 0)
    
55.                             If lngCompPos = 0 Then lngCompLen = lngCompLen - 1
    
56.                         Wend
    
57.                     End If
    
58.                     lngCompLen = lngCompLen - 1
    
59.                     Exit For
    
60.                 End If
    
61.             Next
    
62.             If lngCompLen > lngBytCompLen And lngCompPos > 0 Then
    
63.                 lngCompLen = lngBytCompLen
    
64.                 lngCompPos = InStr(1, strBuffer, Mid(strCompName, lngDataCount, lngCompLen), 0)
    
65.             End If
    
66.             If lngCompPos > 0 Then
    
67.                 lngBuffOffset = lngBuffSize - lngCompPos + 1
    
68.                 LispCompress = LispCompress & Chr((lngBuffOffset And &HFF00) / &H100) & Chr(lngBuffOffset And &HFF) & Chr(lngCompLen)
    
69.                 lngDataCount = lngDataCount + lngCompLen - 1
    
70.                 bytDataCntrlChar = bytDataCntrlChar + 2 ^ bytCntrlPos
    
71.             Else
    
72.                 LispCompress = LispCompress & Mid(strCompName, lngDataCount, 1)
    
73.             End If
    
74.             bytCntrlPos = bytCntrlPos + 1
    
75.             If bytCntrlPos = 8 Then
    
76.                 strDatContrl = strDatContrl & Chr(bytDataCntrlChar)
    
77.                 bytDataCntrlChar = 0
    
78.                 bytCntrlPos = 0
    
79.             End If
    
80. 
    
81.             lngCntr = lngCntr + 1
    
82.             If lngCntr / 1000 = Int(lngCntr / 1000) Then
    
83.             DoEvents
    
84.             End If
    
85.         Next
    
86.         If bytCntrlPos <> 0 Then strDatContrl = strDatContrl & Chr(bytDataCntrlChar)
    
87.         LispCompress = Chr((lngCntr And &H8F000000) / &H1000000) & Chr((lngCntr And &HFF0000) / &H10000) & Chr((lngCntr And &HFF00) / &H100) & Chr(lngCntr And &HFF) & Chr((Len(strDatContrl) And &H8F000000) / &H1000000) & Chr((Len(strDatContrl) And &HFF0000) / &H10000) & Chr((Len(strDatContrl) And &HFF00) / &H100) & Chr(Len(strDatContrl) And &HFF) & strDatContrl & LispCompress
    
88.     Else
    
89.         LispCompress = strCompName
    
90.     End If
    
91. 
    
92. End Function
    
93. 
    
94. [/FONT]

<br /> [FONT=courier new]  <br /> Option Explicit<br /> Dim lngDataCount As Long<br /> Dim lngBufferStart As Long<br /> Dim lngMxBuffSize As Long<br /> Dim strBuffer As String<br /> Dim lngBuffOffset As Long<br /> Dim lngBuffSize As Long<br /> Dim strDatContrl As String<br /> Dim bytDataCntrlChar As Byte<br /> Dim lngCntr As Long<br /> Dim bytCntrlPos As Byte<br /> Dim lngCompLen As Long<br /> Dim lngCompPos As Long<br /> Dim lngBytCompLen As Long<br /> Dim lngControlPos As Long<br /> Dim bytCntrlBitPos As Byte<br /> Dim lngDataPos As Long<br /> Dim lngDecompStart As Long<br /> Dim lngDecompLen As Long<br /> <br /> Public Function LispCompress(strCompName As String) As String<br />     lngMxBuffSize = 55535<br />     lngBytCompLen = 255<br />     lngBufferStart = 0<br />     strDatContrl = ""<br />     bytDataCntrlChar = 0<br />     bytCntrlPos = 0<br />     lngCntr = 0<br />     If Len(strCompName) > 4 Then<br />         LispCompress = Left(strCompName, 4)<br />         For lngDataCount = 5 To Len(strCompName)<br />             If lngDataCount > lngMxBuffSize Then<br />                 lngBuffSize = lngMxBuffSize<br />                 lngBufferStart = lngDataCount - lngMxBuffSize<br />             Else<br />                 lngBuffSize = lngDataCount - 1<br />                 lngBufferStart = 1<br />             End If<br /> <br />             strBuffer = Mid(strCompName, lngBufferStart, lngBuffSize)<br />             If Len(strCompName) - lngDataCount < lngBytCompLen Then lngBytCompLen = Len(strCompName) - lngDataCount<br />             lngCompPos = 0<br />             For lngCompLen = 3 To lngBytCompLen Step 3<br />                 If lngCompLen > lngBytCompLen Then<br />                     lngCompLen = lngBytCompLen<br />                 End If<br />                 lngCompPos = InStr(1, strBuffer, Mid(strCompName, lngDataCount, lngCompLen), 0)<br />                 If lngCompPos = 0 Then<br />                     If lngCompLen > 3 Then<br />                         While lngCompPos = 0<br />                             lngCompPos = InStr(1, strBuffer, Mid(strCompName, lngDataCount, lngCompLen - 1), 0)<br />                             If lngCompPos = 0 Then lngCompLen = lngCompLen - 1<br />                         Wend<br />                     End If<br />                     lngCompLen = lngCompLen - 1<br />                     Exit For<br />                 End If<br />             Next<br />             If lngCompLen > lngBytCompLen And lngCompPos > 0 Then<br />                 lngCompLen = lngBytCompLen<br />                 lngCompPos = InStr(1, strBuffer, Mid(strCompName, lngDataCount, lngCompLen), 0)<br />             End If<br />             If lngCompPos > 0 Then<br />                 lngBuffOffset = lngBuffSize - lngCompPos + 1<br />                 LispCompress = LispCompress & Chr((lngBuffOffset And &HFF00) / &H100) & Chr(lngBuffOffset And &HFF) & Chr(lngCompLen)<br />                 lngDataCount = lngDataCount + lngCompLen - 1<br />                 bytDataCntrlChar = bytDataCntrlChar + 2 ^ bytCntrlPos<br />             Else<br />                 LispCompress = LispCompress & Mid(strCompName, lngDataCount, 1)<br />             End If<br />             bytCntrlPos = bytCntrlPos + 1<br />             If bytCntrlPos = 8 Then<br />                 strDatContrl = strDatContrl & Chr(bytDataCntrlChar)<br />                 bytDataCntrlChar = 0<br />                 bytCntrlPos = 0<br />             End If<br /> <br />             lngCntr = lngCntr + 1<br />             If lngCntr / 1000 = Int(lngCntr / 1000) Then<br />             DoEvents<br />             End If<br />         Next<br />         If bytCntrlPos <> 0 Then strDatContrl = strDatContrl & Chr(bytDataCntrlChar)<br />         LispCompress = Chr((lngCntr And &H8F000000) / &H1000000) & Chr((lngCntr And &HFF0000) / &H10000) & Chr((lngCntr And &HFF00) / &H100) & Chr(lngCntr And &HFF) & Chr((Len(strDatContrl) And &H8F000000) / &H1000000) & Chr((Len(strDatContrl) And &HFF0000) / &H10000) & Chr((Len(strDatContrl) And &HFF00) / &H100) & Chr(Len(strDatContrl) And &HFF) & strDatContrl & LispCompress<br />     Else<br />         LispCompress = strCompName<br />     End If<br /> <br /> End Function<br /> <br /> [/FONT]

2. 
   
3. [FONT=courier new]
   
4. Public Function LispUncompress(strUnComName As String) As String
   
5. If Len(strUnComName) > 4 Then
   
6.         lngCntr = Asc(Left(strUnComName, 1)) * &H1000000 + Asc(Mid(strUnComName, 2, 1)) * &H10000 + Asc(Mid(strUnComName, 3, 1)) * &H100 + Asc(Mid(strUnComName, 4, 1))
   
7.         lngDataCount = Asc(Mid(strUnComName, 5, 1)) * &H1000000 + Asc(Mid(strUnComName, 6, 1)) * &H10000 + Asc(Mid(strUnComName, 7, 1)) * &H100 + Asc(Mid(strUnComName, 8, 1)) + 9
   
8.         LispUncompress = Mid(strUnComName, lngDataCount, 4)
   
9.         lngDataCount = lngDataCount + 4
   
10.         bytCntrlBitPos = 0
    
11.         lngControlPos = 9
    
12.         For lngDataPos = 1 To lngCntr
    
13.             If 2 ^ bytCntrlBitPos = (Asc(Mid(strUnComName, lngControlPos, 1)) And 2 ^ bytCntrlBitPos) Then
    
14.                 lngDecompStart = Len(LispUncompress) - (CLng(Asc(Mid(strUnComName, lngDataCount, 1))) * &H100 + CLng(Asc(Mid(strUnComName, lngDataCount + 1, 1)))) + 1
    
15.                 lngDecompLen = Asc(Mid(strUnComName, lngDataCount + 2, 1))
    
16.                 LispUncompress = LispUncompress & Mid(LispUncompress, lngDecompStart, lngDecompLen)
    
17.                 lngDataCount = lngDataCount + 3
    
18.             Else
    
19.                 LispUncompress = LispUncompress & Mid(strUnComName, lngDataCount, 1)
    
20.                 lngDataCount = lngDataCount + 1
    
21.             End If
    
22.             bytCntrlBitPos = bytCntrlBitPos + 1
    
23.             If bytCntrlBitPos = 8 Then
    
24.                 bytCntrlBitPos = 0
    
25.                 lngControlPos = lngControlPos + 1
    
26.             End If
    
27.         Next
    
28.     Else
    
29.         LispUncompress = strUnComName
    
30.     End If
    
31. End Function[/FONT]

<br /> [FONT=courier new]<br /> Public Function LispUncompress(strUnComName As String) As String<br /> If Len(strUnComName) > 4 Then<br />         lngCntr = Asc(Left(strUnComName, 1)) * &H1000000 + Asc(Mid(strUnComName, 2, 1)) * &H10000 + Asc(Mid(strUnComName, 3, 1)) * &H100 + Asc(Mid(strUnComName, 4, 1))<br />         lngDataCount = Asc(Mid(strUnComName, 5, 1)) * &H1000000 + Asc(Mid(strUnComName, 6, 1)) * &H10000 + Asc(Mid(strUnComName, 7, 1)) * &H100 + Asc(Mid(strUnComName, 8, 1)) + 9<br />         LispUncompress = Mid(strUnComName, lngDataCount, 4)<br />         lngDataCount = lngDataCount + 4<br />         bytCntrlBitPos = 0<br />         lngControlPos = 9<br />         For lngDataPos = 1 To lngCntr<br />             If 2 ^ bytCntrlBitPos = (Asc(Mid(strUnComName, lngControlPos, 1)) And 2 ^ bytCntrlBitPos) Then<br />                 lngDecompStart = Len(LispUncompress) - (CLng(Asc(Mid(strUnComName, lngDataCount, 1))) * &H100 + CLng(Asc(Mid(strUnComName, lngDataCount + 1, 1)))) + 1<br />                 lngDecompLen = Asc(Mid(strUnComName, lngDataCount + 2, 1))<br />                 LispUncompress = LispUncompress & Mid(LispUncompress, lngDecompStart, lngDecompLen)<br />                 lngDataCount = lngDataCount + 3<br />             Else<br />                 LispUncompress = LispUncompress & Mid(strUnComName, lngDataCount, 1)<br />                 lngDataCount = lngDataCount + 1<br />             End If<br />             bytCntrlBitPos = bytCntrlBitPos + 1<br />             If bytCntrlBitPos = 8 Then<br />                 bytCntrlBitPos = 0<br />                 lngControlPos = lngControlPos + 1<br />             End If<br />         Next<br />     Else<br />         LispUncompress = strUnComName<br />     End If<br /> End Function[/FONT]

XDSoft

谢谢！加10分。

能给大家介绍下程序的作用吗？