VB.net壓縮圖片代碼 net 圖片壓縮

vb.net進行文件壓縮

如果機器安裝有winRar軟件，就可以通過shell來借用他的功能達到壓縮文件的效果；

公司主營業(yè)務：成都做網(wǎng)站、成都網(wǎng)站設計、移動網(wǎng)站開發(fā)等業(yè)務。幫助企業(yè)客戶真正實現(xiàn)互聯(lián)網(wǎng)宣傳，提高企業(yè)的競爭能力。創(chuàng)新互聯(lián)公司是一支青春激揚、勤奮敬業(yè)、活力青春激揚、勤奮敬業(yè)、活力澎湃、和諧高效的團隊。公司秉承以“開放、自由、嚴謹、自律”為核心的企業(yè)文化，感謝他們對我們的高要求，感謝他們從不同領(lǐng)域給我們帶來的挑戰(zhàn)，讓我們激情的團隊有機會用頭腦與智慧不斷的給客戶帶來驚喜。創(chuàng)新互聯(lián)公司推出平輿免費做網(wǎng)站回饋大家。

參考代碼如下：

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命令調(diào)用winrar.exe創(chuàng)建壓縮文件()

Dim winRarexe As String = "C:\Program Files\WinRAR\Rar" 'winzip 執(zhí)行文件的位置

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格式的圖片轉(zhuǎn)換為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

'從句柄創(chuàng)建 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

'設置解碼器參數(shù)

tParams.Count = 1

With tParams.Parameter ' Quality

'得到Quality參數(shù)的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文件縮放至不大于指定的字節(jié)數(shù)

1.我有個思路可以嘗試一下：把一張字節(jié)數(shù)在280-300K的圖片用PS打開看看像素大?。?/p>

2.定義一個新的位圖，指定像素大小為上面得到的數(shù)據(jù)；

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

我想用VB寫一個壓縮圖片的程序，應該怎么寫

如果你是僅僅為了壓縮，而不是為了編程，你可以用ACDSee，他可以批量操作，方法是在ACDSee中選擇你需要壓縮的全部文件，點 工具 調(diào)整大小 選項很明顯，你試一試。

你非要用程序的話，看看一下參考

注意：

PicClipD的ScaleMode=vbPixels

源圖像是ImgSrc

目的圖像是PicDest，注意它的屬性

最關(guān)鍵的實現(xiàn)過程在CmdMake_Click

將下列內(nèi)容復制到記事本，并保存為相應的文件

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

'得到數(shù)值

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 "錯誤的數(shù)值！", vbCritical

Exit Sub

ErrSetSize:

MsgBox "無法創(chuàng)建這么大的圖片！", 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內(nèi)的控件

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

'--設置數(shù)值

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 的解壓參數(shù)格式，然后把winrar.exe和相關(guān)文件加入到資源文件中，然后調(diào)用 資源文件中的winrar.exe

2、弄明白rar/zip文件解壓/壓縮方法和格式，自己寫程序 (可能會比較麻煩)

當前標題：VB.net壓縮圖片代碼 net 圖片壓縮
網(wǎng)站地址：http://muchs.cn/article24/docccce.html

成都網(wǎng)站建設公司_創(chuàng)新互聯(lián)，為您提供企業(yè)網(wǎng)站制作、營銷型網(wǎng)站建設、定制開發(fā)、全網(wǎng)營銷推廣、建站公司、外貿(mào)網(wǎng)站建設

廣告

聲明：本網(wǎng)站發(fā)布的內(nèi)容（圖片、視頻和文字）以用戶投稿、用戶轉(zhuǎn)載內(nèi)容為主，如果涉及侵權(quán)請盡快告知，我們將會在第一時間刪除。文章觀點不代表本網(wǎng)站立場，如需處理請聯(lián)系客服。電話：028-86922220；郵箱：631063699@qq.com。內(nèi)容未經(jīng)允許不得轉(zhuǎn)載，或轉(zhuǎn)載時需注明來源： 創(chuàng)新互聯(lián)