vb.net图片压缩 net 图片压缩

我想用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 怎么把本地图像压缩 怎 后 在转换到 MemoryStream里面呢?

Dim s As New MemoryStream()

Dim pic As New Bitmap("c:\AeroSnap截图1.bmp") 

Dim SngPer As Single = 2 / 10

Dim PicOld As Image = pic 

Dim PicNew As New System.Drawing.Bitmap(PicOld, PicOld.Width * SngPer, PicOld.Height * SngPer)

PicNew.Save(s, Drawing.Imaging.ImageFormat.Jpeg)

s.Seek(0,SeekOrigin.Begin)

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

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

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

asp.net如何实现 图片压缩（vb.net）

'''''''''''''''tosmallimg.aspx''

%@ Page Language="VB" AutoEventWireup="false" CodeFile="tosmallpic.aspx.vb" Inherits="tosmallpic" %

%@ OutputCache Duration="86400" VaryByParam="*" %

!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" ""

html xmlns=""

head runat="server"

title无标题页/title

/head

body

form id="form1" runat="server"

div

/div

/form

/body

/html

'''''''''''''''tosmallimg.aspx.vb''

Imports System.Drawing, System.Drawing.Imaging, System.Drawing.Drawing2D

Partial Class tosmallpic

Inherits System.Web.UI.Page

Protected Sub Page_Load(ByVal sender As Object, ByVal e As System.EventArgs) Handles Me.Load

Dim width As Int16 = CInt(My.Request.QueryString("width"))

Dim height As Int16 = CInt(My.Request.QueryString("height"))

Dim url As String = My.Request.QueryString("url")

If Not System.IO.File.Exists(Server.MapPath(url)) Then

Response.Redirect("img/default.jpg")

Response.End()

End If

Dim img As Image = Image.FromFile(Server.MapPath(url))

If width = 0 And height 0 Then

width = height * img.Width / img.Height

ElseIf height = 0 Then

height = width * img.Height / img.Width

End If

If width img.Width Then Response.Redirect(url)

Dim bmp As New Bitmap(width, height)

Dim gr As Graphics = Graphics.FromImage(bmp)

gr.Clear(Color.Transparent)

'gr.SmoothingMode = SmoothingMode.AntiAlias

Dim rct As New Rectangle(0, 0, width, height)

gr.DrawImage(img, New Rectangle(0, 0, width, height), New Rectangle(0, 0, img.Width, img.Height), GraphicsUnit.Pixel)

Response.Clear()

Response.ContentType = "image/jpeg"

bmp.Save(Response.OutputStream, ImageFormat.Jpeg)

End Sub

End Class

介绍下我的blog