Quiero escribir un programa para comprimir imágenes usando VB. ¿Cómo debo escribirlo?
Si solo desea comprimir, no programar, puede usar ACDSee, que puede funcionar en lotes. El método consiste en seleccionar todos los archivos que necesita comprimir en ACDSee y hacer clic en la herramienta para ajustar. el tamaño La opción es obvia.
Si insistes en usar algún programa, echa un vistazo a la referencia
Nota:
PicClipD's ScaleMode=vbPixels
La fuente la imagen es ImgSrc
La imagen de destino es PicDest, preste atención a sus propiedades
El proceso de implementación más crítico es CmdMake_Click
Copie el siguiente contenido en el Bloc de notas y guárdelo como el archivo correspondiente
PicScale.vbp
--------------------
Tipo =Exe
p>Form=FrmMain.frm
Referencia=*\G{00020430-0000-0000-C000-000000000046}#2.0#0#..\..\ ..\..\ WINDOWS\system32\stdole2.tlb#Automatización OLE
Objeto={F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0; >IconForm="FrmMain"
Inicio="FrmMain"
HelpFile=""
ExeName32="PicScale.exe" "
Command32="" "
Name="PicScale"
HelpContextID="0"
CompatibleMode="0"
MajorVer =1
MinorVer=0
RevisionVer=0
AutoIncrementVer=0
ServerSupportFiles=0
Tipo de compilación =0
OptimizationType=0
FavorPentiumPro(tm)=0
CodeViewDebugInfo=0
NoAliasing=0
BoundsCheck=0
OverflowCheck=0
FlPointCheck=0
FDIVCheck=0
UnroundedFP=0
StartMode=0
Desatendido=0
Retenido=0
ThreadPerObject=0
MaxNumberOfThreads=1
[MS Transaction Server ]
AutoRefresh=1
FrmMain.frm
---------------- ------- ------------
VERSIÓN 5.00
Objeto = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}# 1.2#0"; "COMDLG32 .OCX"
Comenzar VB.Form FrmMain
Caption = "Escalado de archivo de imagen simple"
<p> ClientHeight = 3810
ClientLeft = 165
ClientTop = 855
ClientWidth = 5505
HasDC = 0 'Falso
LinkTopic = "Form1"
ScaleHeight = 254
ScaleMode = 3 'Pixel
ScaleWidth = 367
StartUpPosition = 3 'Ventana predeterminada
Comenzar MSComDlg.CommonDialog CDlgFile
Izquierda = 2160
Superior = 1320
_ExtentX = 847
_ExtentY = 847
_Version = 393216
Fin
Comenzar VB.PictureBox PicClipD
BackColor = amp;H8000000Camp; /p>
HasDC = 0 'False
Altura = 1695
Izquierda = 2520
ScaleHeight = 109
ScaleMode = 3 'Pixel
ScaleWidth = 117
TabIndex = 8
TabStop = 0 'False
Superior = 840
Ancho = 1815
Comenzar VB.PictureBox PicDest
AutoRedraw = -1 'True
BackColor = amp;H00FFFFFFamp;
BorderStyle = 0 'Ninguno
Alto = 495
Izquierda = 240
ScaleHeight = 33
ScaleMode = 3
'Pixel
ScaleWidth = 65
TabIndex = 9
TabStop = 0 'False
Superior = 360
Ancho = 975
Fin
Fin
Inicio VB.PictureBox PicClipS
BackColor = amp;H8000000Camp;
HasDC = 0 'False
Altura = 1575
Izquierda = 360
ScaleHeight = 101
ScaleMode = 3 'Pixel
ScaleWidth = 101
TabIndex = 7
TabStop = 0 'False
Superior = 840
Ancho = 1575
Comenzar VB.Image ImgSrc
Alto = 855
Izquierda = 240
Arriba = 240
Ancho = 855
Fin
Fin
Inicio VB.PictureBox PicToolBar
Alineación = 1 'Alinear arriba
HasDC = 0 'False
Altura = 495
Izquierda = 0
ScaleHeight = 29
ScaleMode = 3 'Pixel
ScaleWidth = 363
TabIndex = 0
TabStop = 0 'False
Superior = 0
Ancho = 5505
B
comenzar VB.CommandButton CmdReset
Caption = "Restablecer"
Alto = 255
Izquierda = 3960
TabIndex = 6
Superior = 120
Ancho = 780
Fin
Inicio VB.CommandButton CmdMake
Título = "Generar"
Alto = 255
Izquierda = 3120
TabIndex = 5
Superior = 120
Ancho = 780
Fin
Comienzo VB.TextBox TxtHeight
Alto = 270
Izquierda = 2280
TabIndex = 4
Texto = "Texto1"
Superior = 120
Ancho = 750
Fin
Inicio VB.TextBox TxtWidth
Alto = 270
Izquierda = 720
TabIndex = 2
Texto = "Texto1"
Superior = 120
Ancho = 750
Fin
Inicio VB.Label LblHeight
AutoSize = -1 'True
Título = "Altura:"
Altura = 180
Izquierda = 1680
TabIndex =
3
Top = 120
Ancho = 630
Fin
Comenzar VB.Label LblWidth
AutoSize = -1 'Verdadero
Título = "amp; Ancho:"
Alto = 180
Izquierda = 120
TabIndex = 1
Top = 120
Ancho = 540
Fin
Fin
Comenzar VB.Menu mnuFile
Caption = "Archivo (amp; F)"
Comenzar VB.Menu mnuOpen
Caption = "Abrir (amp; O)..."
Fin
Comenzar VB.Menu mnuSave
Caption = "Guardar(amp;S)..."
Fin
Empezar VB.Menu mnuSep0_0
Caption = "-"
Fin
Empezar VB.Menu mnuSalir
Caption = "Salir( amp VB_GlobalNameSpace = False
Atributo VB_Creatable = False
Atributo VB_PredeclaredId = True
Atributo VB_Exposed = False
Opción explícita
Private Const CtlSpace = 4 'Distancia entre controles
Private Sub CmdMake_Click()
Atenuar nWidth As Long
Atenuar nHeight As Long
'Obtener el valor
En caso de error Ir a ErrNum
nW
idth = CLng(TxtWidth.Text)
nHeight = CLng(TxtHeight.Text)
En caso de error Ir a 0
Si nWidth lt; 1 Luego, vaya a ErrNum
'Cambiar tamaño
en caso de error, vaya a ErrSetSize
PicDest.Move 0, 0, nWidth, nHeight
en Error GoTo 0
'Cancelar el caché de PictureBox
Establecer PicDest.Picture = Nothing
'Dibujar la imagen
PicDest.PaintPicture ImgSrc, 0, 0, PicDest.ScaleWidth, PicDest.ScaleHeight
Salir de Sub
ErrNum:
MsgBox "¡Valor incorrecto!", vbCritical
Salir de Sub
ErrSetSize:
MsgBox "¡No se puede crear una imagen tan grande!", vbCritical
Salir de Sub
End Sub
Private Sub CmdReset_Click()
Si ImgSrc.Picture.Type = vbPicTypeNone Entonces 'Sin imagen
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
Llamar a CmdMake_Click
Finalizar si
End Sub
Private Sub Form_Load()
'-- Inicializar posicionamiento de coordenadas
Dim SM_Me As Long
Dim SM_Tbr Mientras
Dim nTemp As Long
SM_Me = Me.ScaleMode
SM_Tbr = PicToolBar.ScaleMode
'Coloca la altura de PicToolBar
Con PicToolBar
'Calcular tamaño de borde
nTemp = Me.ScaleY(.Height, SM_Me, vbPixels) - .ScaleY(.ScaleHeight, SM_Tbr, vbPixels)
' Calcular PicToolBar debe tener una altura
nTemp = nTemp .ScaleY(TxtWidth.Height, SM_Tbr, vbPixels)
'Establecer altura
.Height = Me.ScaleY (nTemp , vbPixels, SM_Me)
Terminar con
'Colocar el control dentro de 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
'--Establecer valor
Llamar a CmdReset_Click
Con CDlgFile
.CancelarError =Tr
ue
.Flags = cdlOFNOverwritePrompt Or cdlOFNHideReadOnly
.Filter = "Windows Bitmap (*.bmp)|*.bmp|Todos los archivos (*.*)|*.*"
Terminar con
Finalizar sub
Sub privado Form_Resize()
Si Me.WindowState = 1, entonces salir de Sub
En caso de error, reanudar siguiente
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 ()
Descargarme
Finalizar sub
Sub privado mnuOpen_Click()
En caso de error Reanudar siguiente
CDlgFile.ShowOpen
Si Err.Number entonces salga de Sub 'Haga clic para cancelar
'Abrir
Establezca ImgSrc.Picture = LoadPicture(CDlgFile.FileName)< / p>
Si Err.Number Entonces
MsgBox "¡No se puede abrir el archivo! ", vbCritical
Salir de Sub
Finalizar si
En caso de error Ir a 0
Llamar a CmdReset_Click
Finalizar Sub
Sub privado mnuSave_Click()
En caso de error, reanudar siguiente
CDlgFile.ShowSave
Si Err.Number, salga de Sub 'Se hizo clic en Cancelar
'Guardar
Guardar imagen PicDest.Imagen, CDlgFile.File
Nombre
Si Err.Number Entonces
MsgBox "¡No se puede guardar la imagen!", vbCritical
Salir de Sub
Fin si
En caso de error Ir a 0
Finalizar sub