vb.net进行文件压缩

如果机器安装有winRar软件，就可以通过shell来借用他的功能达到压缩文件的效果；

公司主营业务：成都做网站、成都网站设计、移动网站开发等业务。帮助企业客户真正实现互联网宣传，提高企业的竞争能力。创新互联公司是一支青春激扬、勤奋敬业、活力青春激扬、勤奋敬业、活力澎湃、和谐高效的团队。公司秉承以“开放、自由、严谨、自律”为核心的企业文化，感谢他们对我们的高要求，感谢他们从不同领域给我们带来的挑战，让我们激情的团队有机会用头脑与智慧不断的给客户带来惊喜。创新互联公司推出平舆免费做网站回馈大家。

参考代码如下：

Dim DeliveryF As String = Server.MapPath("..\Temp\DeliveryFactors.xls") '原始文件 (压缩前)

Dim TruckInfo As String = Server.MapPath("..\Temp\TruckInformation.xls")

Dim QDetail As String = Server.MapPath("..\Temp\QuotationDetail.xls")

'用shell命令调用winrar.exe创建压缩文件()

Dim winRarexe As String = "C:\Program Files\WinRAR\Rar" 'winzip 执行文件的位置

Dim wtarget As String = "C:\temp\QuotationVAComparsion.zip" '目地文件 (压缩后)

Dim command As String = winRarexe " a " wtarget " " DeliveryF " " TruckInfo " " QDetail

'这个命令你可以查看winrar的命令集

Dim retval As Double 'Shell 指令传回值

retval = Shell(command, AppWinStyle.MinimizedFocus)

vb中将bmp格式的图片转换为JPG格式。要代码，最好越简单越好

下面是源代码:

添加picturebox,commandbutton

Option Explicit

Private Type GUID

Data1 As Long

Data2 As Integer

Data3 As Integer

Data4(0 To 7) As Byte

End Type

Private Type GdiplusStartupInput

GdiplusVersion As Long

DebugEventCallback As Long

SuppressBackgroundThread As Long

SuppressExternalCodecs As Long

End Type

Private Type EncoderParameter

GUID As GUID

NumberOfValues As Long

type As Long

Value As Long

End Type

Private Type EncoderParameters

Count As Long

Parameter As EncoderParameter

End Type

Private Declare Function GdiplusStartup Lib "GDIPlus" (token As Long, inputbuf As GdiplusStartupInput, ByVal outputbuf As Long) As Long

Private Declare Function GdiplusShutdown Lib "GDIPlus" (ByVal token As Long) As Long

Private Declare Function GdipCreateBitmapFromHBITMAP Lib "GDIPlus" (ByVal hbm As Long, ByVal hpal As Long, Bitmap As Long) As Long

Private Declare Function GdipDisposeImage Lib "GDIPlus" (ByVal Image As Long) As Long

Private Declare Function GdipSaveImageToFile Lib "GDIPlus" (ByVal Image As Long, ByVal filename As Long, clsidEncoder As GUID, encoderParams As Any) As Long

Private Declare Function CLSIDFromString Lib "ole32" (ByVal str As Long, id As GUID) As Long

Private Declare Function GdipCreateBitmapFromFile Lib "GDIPlus" (ByVal filename As Long, Bitmap As Long) As Long

Private Sub Command1_Click()

Dim ret As Boolean

Picture1.Picture = LoadPicture("C:\a.bmp") '打开要压缩的图片

ret = PictureBoxSaveJPG(Picture1, "C:\b.jpg") '保存压缩后的图片

If ret = False Then

MsgBox "保存失败"

End If

End Sub

Private Function PictureBoxSaveJPG(ByVal pict As StdPicture, ByVal filename As String, Optional ByVal quality As Byte = 80) As Boolean

Dim tSI As GdiplusStartupInput

Dim lRes As Long

Dim lGDIP As Long

Dim lBitmap As Long

'初始化 GDI+

tSI.GdiplusVersion = 1

lRes = GdiplusStartup(lGDIP, tSI, 0)

If lRes = 0 Then

'从句柄创建 GDI+ 图像

lRes = GdipCreateBitmapFromHBITMAP(pict.Handle, 0, lBitmap)

If lRes = 0 Then

Dim tJpgEncoder As GUID

Dim tParams As EncoderParameters

'初始化解码器的GUID标识

CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder

'设置解码器参数

tParams.Count = 1

With tParams.Parameter ' Quality

'得到Quality参数的GUID标识

CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .GUID

.NumberOfValues = 1

.type = 4

.Value = VarPtr(quality)

End With

'保存图像

lRes = GdipSaveImageToFile(lBitmap, StrPtr(filename), tJpgEncoder, tParams)

'销毁GDI+图像

GdipDisposeImage lBitmap

End If

'销毁 GDI+

GdiplusShutdown lGDIP

End If

If lRes Then

PictureBoxSaveJPG = False

Else

PictureBoxSaveJPG = True

End If

End Function

;tn=baiduPostBrowsersc=3183913151z=314561243pn=0rn=50lm=0word=vb#3183913151

vb.net如何将JPG文件缩放至不大于指定的字节数

1.我有个思路可以尝试一下：把一张字节数在280-300K的图片用PS打开看看像素大小；

2.定义一个新的位图，指定像素大小为上面得到的数据；

3.读取你需要修改大小的JPG文件，然后按指定大小复制到上面新建的位图，并保存为JPG格式

我想用VB写一个压缩图片的程序，应该怎么写

如果你是仅仅为了压缩，而不是为了编程，你可以用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#0; COMDLG32.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

vb.net 如何压缩、解压缩文件

1、你先搞懂 winrar.exe 的解压参数格式，然后把winrar.exe和相关文件加入到资源文件中，然后调用 资源文件中的winrar.exe

2、弄明白rar/zip文件解压/压缩方法和格式，自己写程序 (可能会比较麻烦)

分享名称：VB.net压缩图片代码 net 图片压缩
文章转载：http://myzitong.com/article/docccce.html