VB如何编字典压缩程序?

待压缩的文件在

http://202.99.99.42/read/frmfcus.frx

压缩算法的代码很长我就不贴了

vb6中用

zlib.dll实现压缩/解压缩

字节数组

http://www.chenoe.com/blog/article.asp?id=2046

转贴请注明出处

作者：塞北雪貂

Option

Explicit

'Declares

Private

Declare

Sub

CopyMemory

Lib

"kernel32"

Alias

"RtlMoveMemory"

(hpvDest

As

Any,

hpvSource

As

Any,

ByVal

cbCopy

As

Long)

Private

Declare

Function

Compress

Lib

"zlibwapi.dll"

Alias

"compress"

(dest

As

Any,

destLen

As

Any,

src

As

Any,

ByVal

srcLen

As

Long)

As

Long

Private

Declare

Function

uncompress

Lib

"zlibwapi.dll"

(dest

As

Any,

destLen

As

Any,

src

As

Any,

ByVal

srcLen

As

Long)

As

Long

Private

Const

OFFSET

As

Long

=

&H8

'压缩数组

Public

Function

CompressByte(ByteArray()

As

Byte)

As

Boolean

Dim

BufferSize

As

Long

Dim

TempBuffer()

As

Byte

'Create

a

buffer

to

hold

the

compressed

data

BufferSize

=

UBound(ByteArray)

+

1

BufferSize

=

BufferSize

+

(BufferSize

*

0.01)

+

12

ReDim

TempBuffer(BufferSize)

'Compress

byte

array

(data)

CompressByte

=

(Compress(TempBuffer(0),

BufferSize,

ByteArray(0),

UBound(ByteArray)

+

1)

=

0)

'Add

the

size

of

the

original

data

Call

CopyMemory(ByteArray(0),

CLng(UBound(ByteArray)

+

1),

OFFSET)

'Remove

redundant

data

ReDim

Preserve

ByteArray(0

To

BufferSize

+

OFFSET

-

1)

CopyMemory

ByteArray(OFFSET),

TempBuffer(0),

BufferSize

End

Function

'解压缩数组

Public

Function

UnCompressByte(ByteArray()

As

Byte)

As

Boolean

Dim

origLen

As

Long

Dim

BufferSize

As

Long

Dim

TempBuffer()

As

Byte

'Get

the

original

size

Call

CopyMemory(OrigLen,

ByteArray(0),

OFFSET)

'Create

a

buffer

to

hold

the

uncompressed

data

BufferSize

=

origLen

BufferSize

=

BufferSize

+

(BufferSize

*

0.01)

+

12

ReDim

TempBuffer(BufferSize)

'Decompress

data

UnCompressByte

=

(uncompress(TempBuffer(0),

BufferSize,

ByteArray(OFFSET),

UBound(ByteArray)

-

OFFSET

+

1)

=

0)

'Remove

redundant

data

ReDim

Preserve

ByteArray(0

To

BufferSize

-

1)

CopyMemory

ByteArray(0),

TempBuffer(0),

BufferSize

End

Function

如果你是仅仅为了压缩，而不是为了编程，你可以用ACDSee，他可以批量 *** 作，方法是在ACDSee中选择你需要压缩的全部文件，点 工具 调整大小 选项很明显，你试一试。

你非要用程序的话，看看一下参考

注意：

PicClipD的ScaleMode=vbPixels

源图像是ImgSrc

目的图像是PicDest，注意它的属性

最关键的实现过程在CmdMake_Click

将下列内容复制到记事本，并保存为相应的文件

PicScale.vbp

--------------------

Type=Exe

Form=FrmMain.frm

Reference=*\G{00020430-0000-0000-C000-000000000046}#2.0#0#..\..\..\..\WINDOWS\system32\stdole2.tlb#OLE Automation

Object={F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0COMDLG32.OCX

IconForm="FrmMain"

Startup="FrmMain"

HelpFile=""

ExeName32="PicScale.exe" "

Command32="" "

Name="PicScale"

HelpContextID="0"

CompatibleMode="0"

MajorVer=1

MinorVer=0

RevisionVer=0

AutoIncrementVer=0

ServerSupportFiles=0

CompilationType=0

OptimizationType=0

FavorPentiumPro(tm)=0

CodeViewDebugInfo=0

NoAliasing=0

BoundsCheck=0

OverflowCheck=0

FlPointCheck=0

FDIVCheck=0

UnroundedFP=0

StartMode=0

Unattended=0

Retained=0

ThreadPerObject=0

MaxNumberOfThreads=1

[MS Transaction Server]

AutoRefresh=1

FrmMain.frm

----------------------------------

VERSION 5.00

Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0""COMDLG32.OCX"

Begin VB.Form FrmMain

Caption = "简单图像文件缩放"

ClientHeight= 3810

ClientLeft = 165

ClientTop = 855

ClientWidth = 5505

HasDC = 0 'False

LinkTopic = "Form1"

ScaleHeight = 254

ScaleMode = 3 'Pixel

ScaleWidth = 367

StartUpPosition = 3 '窗口缺省

Begin MSComDlg.CommonDialog CDlgFile

Left= 2160

Top = 1320

_ExtentX= 847

_ExtentY= 847

_Version= 393216

End

Begin VB.PictureBox PicClipD

BackColor = &H8000000C&

HasDC = 0 'False

Height = 1695

Left= 2520

ScaleHeight = 109

ScaleMode = 3 'Pixel

ScaleWidth = 117

TabIndex= 8

TabStop = 0 'False

Top = 840

Width = 1815

Begin VB.PictureBox PicDest

AutoRedraw = -1 'True

BackColor = &H00FFFFFF&

BorderStyle = 0 'None

Height = 495

Left= 240

ScaleHeight = 33

ScaleMode = 3 'Pixel

ScaleWidth = 65

TabIndex= 9

TabStop = 0 'False

Top = 360

Width = 975

End

End

Begin VB.PictureBox PicClipS

BackColor = &H8000000C&

HasDC = 0 'False

Height = 1575

Left= 360

ScaleHeight = 101

ScaleMode = 3 'Pixel

ScaleWidth = 101

TabIndex= 7

TabStop = 0 'False

Top = 840

Width = 1575

Begin VB.Image ImgSrc

Height = 855

Left= 240

Top = 240

Width = 855

End

End

Begin VB.PictureBox PicToolBar

Align = 1 'Align Top

HasDC = 0 'False

Height = 495

Left= 0

ScaleHeight = 29

ScaleMode = 3 'Pixel

ScaleWidth = 363

TabIndex= 0

TabStop = 0 'False

Top = 0

Width = 5505

Begin VB.CommandButton CmdReset

Caption = "复位"

Height = 255

Left= 3960

TabIndex= 6

Top = 120

Width = 780

End

Begin VB.CommandButton CmdMake

Caption = "生成"

Height = 255

Left= 3120

TabIndex= 5

Top = 120

Width = 780

End

Begin VB.TextBox TxtHeight

Height = 270

Left= 2280

TabIndex= 4

Text= "Text1"

Top = 120

Width = 750

End

Begin VB.TextBox TxtWidth

Height = 270

Left= 720

TabIndex= 2

Text= "Text1"

Top = 120

Width = 750

End

Begin VB.Label LblHeight

AutoSize= -1 'True

Caption = "Height:"

Height = 180

Left= 1680

TabIndex= 3

Top = 120

Width = 630

End

Begin VB.Label LblWidth

AutoSize= -1 'True

Caption = "&Width:"

Height = 180

Left= 120

TabIndex= 1

Top = 120

Width = 540

End

End

Begin VB.Menu mnuFile

Caption = "文件(&F)"

Begin VB.Menu mnuOpen

Caption = "打开(&O)..."

End

Begin VB.Menu mnuSave

Caption = "保存(&S)..."

End

Begin VB.Menu mnuSep0_0

Caption = "-"

End

Begin VB.Menu mnuExit

Caption = "退出(&X)"

End

End

End

Attribute VB_Name = "FrmMain"

Attribute VB_GlobalNameSpace = False

Attribute VB_Creatable = False

Attribute VB_PredeclaredId = True

Attribute VB_Exposed = False

Option Explicit

Private Const CtlSpace = 4 '控件之间的距离

Private Sub CmdMake_Click()

Dim nWidth As Long

Dim nHeight As Long

'得到数值

On Error GoTo ErrNum

nWidth = CLng(TxtWidth.Text)

nHeight = CLng(TxtHeight.Text)

On Error GoTo 0

If nWidth <1 Or nHeight <1 Then GoTo ErrNum

'改变大小

On Error GoTo ErrSetSize

PicDest.Move 0, 0, nWidth, nHeight

On Error GoTo 0

'取消PictureBox的缓存

Set PicDest.Picture = Nothing

'绘制图像

PicDest.PaintPicture ImgSrc, 0, 0, PicDest.ScaleWidth, PicDest.ScaleHeight

Exit Sub

ErrNum:

MsgBox "错误的数值！", vbCritical

Exit Sub

ErrSetSize:

MsgBox "无法创建这么大的图片！", vbCritical

Exit Sub

End Sub

Private Sub CmdReset_Click()

If ImgSrc.Picture.Type = vbPicTypeNone Then '无图片

TxtWidth.Text = CStr(1)

TxtHeight.Text = CStr(1)

CmdMake.Enabled = False

Else

TxtWidth.Text = CStr(ImgSrc.Width)

TxtHeight.Text = CStr(ImgSrc.Height)

CmdMake.Enabled = True

Call CmdMake_Click

End If

End Sub

Private Sub Form_Load()

'-- 初始化坐标定位

Dim SM_Me As Long

Dim SM_Tbr As Long

Dim nTemp As Long

SM_Me = Me.ScaleMode

SM_Tbr = PicToolBar.ScaleMode

'定位PicToolBar的高度

With PicToolBar

'计算边框大小

nTemp = Me.ScaleY(.Height, SM_Me, vbPixels) - .ScaleY(.ScaleHeight, SM_Tbr, vbPixels)

'计算PicToolBar应有高度

nTemp = nTemp + .ScaleY(TxtWidth.Height, SM_Tbr, vbPixels)

'设置高度

.Height = Me.ScaleY(nTemp, vbPixels, SM_Me)

End With

'定位PicToolBar内的控件

nTemp = PicToolBar.ScaleHeight

LblWidth.Move CtlSpace, (nTemp - LblWidth.Height) / 2

TxtWidth.Move LblWidth.Left + LblWidth.Width, 0

LblHeight.Move TxtWidth.Left + TxtWidth.Width + CtlSpace, (nTemp - LblWidth.Height) / 2

TxtHeight.Move LblHeight.Left + LblHeight.Width, 0, TxtHeight.Width, TxtWidth.Height

CmdMake.Move TxtHeight.Left + TxtHeight.Width + CtlSpace, 0, CmdMake.Width, TxtWidth.Height

CmdReset.Move CmdMake.Left + CmdMake.Width + CtlSpace, 0, CmdReset.Width, TxtWidth.Height

ImgSrc.Move 0, 0

PicDest.Move 0, 0

'--设置数值

Call CmdReset_Click

With CDlgFile

.CancelError = True

.Flags = cdlOFNOverwritePrompt Or cdlOFNHideReadOnly

.Filter = "Windows位图(*.bmp)|*.bmp|所有文件(*.*)|*.*"

End With

End Sub

Private Sub Form_Resize()

If Me.WindowState = 1 Then Exit Sub

On Error Resume Next

Dim nTemp As Long

nTemp = PicToolBar.Height

PicClipS.Move 0, nTemp, Me.ScaleWidth / 2, Me.ScaleHeight - nTemp

PicClipD.Move PicClipS.Width, nTemp, Me.ScaleWidth - PicClipS.Width, PicClipS.Height

End Sub

Private Sub mnuExit_Click()

Unload Me

End Sub

Private Sub mnuOpen_Click()

On Error Resume Next

CDlgFile.ShowOpen

If Err.Number Then Exit Sub '点了取消

'打开

Set ImgSrc.Picture = LoadPicture(CDlgFile.FileName)

If Err.Number Then

MsgBox "无法打开文件！", vbCritical

Exit Sub

End If

On Error GoTo 0

Call CmdReset_Click

End Sub

Private Sub mnuSave_Click()

On Error Resume Next

CDlgFile.ShowSave

If Err.Number Then Exit Sub '点了取消

'保存

SavePicture PicDest.Image, CDlgFile.FileName

If Err.Number Then

MsgBox "无法保存图片！", vbCritical

Exit Sub

End If

On Error GoTo 0

End Sub

DIR 可以

还可以用FSO 对象,来完成!

Dir 函数

返回一个 String，用以表示一个文件名、目录名或文件夹名称，它必须与指定的模式或文件属性、或磁盘卷标相匹配。

语法

Dir[(pathname[, attributes])]

Dir 函数的语法具有以下几个部分：

部分 描述

pathname 可选参数。用来指定文件名的字符串表达式，可能包含目录或文件夹、以及驱动器。如果没有找到 pathname，则会返回零长度字符串 ("")。

attributes 可选参数。常数或数值表达式，其总和用来指定文件属性。如果省略，则会返回匹配 pathname 但不包含属性的文件。

设置值

attributes 参数的设置可为：

常数 值 描述

vbNormal 0 (缺省) 指定没有属性的文件。

vbReadOnly 1 指定无属性的只读文件

vbHidden 2 指定无属性的隐藏文件

VbSystem 4 指定无属性的系统文件

vbVolume 8 指定卷标文件；如果指定了其它属性，则忽略vbVolume

vbDirectory 16 指定无属性文件及其路径和文件夹。

注意 这些常数是由 VBA 所指定的，在程序代码中的任何位置，可以使用这些常数来替换真正的数值。

---