Salvar JPG con mucho menos peso sin perder calidad

[Fran1946]

Hola a todos:

Os explico mi necesidad, y de paso esto os puede servir a muchos para diminuir mucho el peso de imágenes JPG hechas con cámaras digitales o móviles.

Por casualidad descubrí que abriendo una imagen JPG en msPaint de Windows XP, y sin hacer nada con ella, salvarla con Ctr+g o en el Menú...Archivo...Guardar, lógicamente con el mismo nombre, ahora esa imagen pesará entre el 30 al 85 % menos, un ejemplo real con una de mis imágenes hecha con una cámara Cannon EOS 600D:
Imagen original  pesa 8.89 Mb, la misma cargada en msPaint y salvada pesa 1.44 Mb, o sea 83,80 % menos.
Comparadas en el visor de imágenes de Windows, son exactamente iguales no hay perdida de resolución, no eres capaz de distinguirlas, y con Zoom en Photosop son exactamente iguales y la ficha EXIF también.

Si alguien lo duda que haga la prueba, y si alguien sabe por que ocurre esto que me lo explique.

Entonces he hecho una aplicación, donde hago un Drag & Drop de una carpeta donde haya imagenes JPG, o de varios archivos seleccionados de una carpeta, y solo los que sean JPG se cargan sus rutas completas en un ListBox, luego al pulsar un botón, se genera una carpeta donde se copian todos los JPG's originales de la lista.
Y a continuación se cargaran uno a uno en Paint, y se salvan mandando con SendKeys las pulsaciones Ctr+g, por que no he podido conseguir como mandarle el comando 'Guardar' a Paint desde vb6, si alguien sabe como hacerlo por favor explicármelo.

Pero necesito hacer esa misma aplicación para Windows 7, y el msPaint de Win7, utilizando el mismo 'truco' que el de XP, no reduce nada el peso, pero ejecutando una copia del msPaint de Win XP desde Win7, si funciona y lo hace igual que lo que he mencionado.

Entonces la idea es, tengo una copia de msPaint de Win XP, que se llama 'SDpaint.exe'   

Y la aplicación al ejecutarse, abre 'SDpaint.exe' con Shell:

Y lo que necesito, es que una vez 'SDpaint.exe' esta abierto, sin ninguna imagen, desde mi aplicación cargar una serie de imágenes.jpg una a una desde la lista de un ListBox (que tiene la ruta completa de la imagen), pero en el 'SDpaint.exe' abierto al principio, no me sirve cerrar 'SDpaint.exe' y cargar una imagen en un nuevo 'SDpaint.exe', cerrarlo y cargar la siguiente abriendo otro.

He probado capturando primero el hWnd del 'SDpaint.exe' abierto, en la variable LhWnd , para utilizarlo con ShellExecute así:
L = ShellExecute(LhWnd, "Open", ListFiles.List(i), "", "", 0)
Pero ejecuta el visor de imágenes de Windows, no carga la imagen en el Paint abierto, y creo que esto se debe poder hacer, no encuentro nada en Internet.

Agradecería cualquier ayuda, perdonad el tocho.

Un saludo.

[luis_74]

prueba ejecutando el programa y pasandole la ruta del archivo:

Código [Seleccionar] Expandir



"c:\sdpaint.exe c:\imagen.jpg"



[Fran1946]

Gracias por tu interés, pero creo que no entiendo tu respuesta:

"c:\sdpaint.exe c:\imagen.jpg"
Eso no es código ejecutable, y si te refieres a:

Call Shell("c:\sdpaint.exe c:\imagen.jpg",1) eso tampoco es ejecutable.

[luis_74]

Gracias por tu interés, pero creo que no entiendo tu respuesta:

"c:\sdpaint.exe c:\imagen.jpg"
Eso no es código ejecutable, y si te refieres a:

Call Shell("c:\sdpaint.exe c:\imagen.jpg",1) eso tampoco es ejecutable.

sí ya veo que no anda, bueno cambialo a esto:

Código [Seleccionar] Expandir



ShellExecute 0, "open", "c:\windows\system32\mspaint.exe", "c:\imagen.jpg", "", 1




cambiando las rutas del progrmas y la imagen  ya tienes abierta la imagen en el paint.

lo acabo de probar y si funciona.

[Fran1946]

ShellExecute 0, "open", "c:\windows\system32\mspaint.exe", "c:\imagen.jpg", "", 1

Claro, si llamas al msPaint y la imagen esta en C:\ si funciona, pero si la imagen esta en, por ejemplo, "T:\A\Nueva carpeta\imagen.jpg", entonces no funciona.

Pero creo que no has entendido mi pregunta:

Yo no tengo problema para abrir las imágenes en cualquier ruta y HD, con una copia de 'mspaint.exe', renombrada por mi como 'SDPaint.exe' ubicada en otra ruta diferente a "c:\windows\system32".

En Win XP, mi aplicación funciona 100%, utilizando "c:\windows\system32\mspaint.exe" , donde no funciona es en Win7, por que el mspaint de Win7 es diferente al de Win XP, digamos que es menos básico y tiene mas herramientas, pero al salvar las imágenes no las reduce de peso nada, que es el objetivo de mi aplicación.

Ya he conseguido también ajecutar 'SDPaint' al principio sin ninguna imagen, y luego cargar una a una todas la imágenes con sus rutas completas de la lista de un ListBox, lo único que no he conseguido es mandarle el comando Ctr+g, que es lo que salva la imagen cargada en 'SDPaint', por que haciendolo con:
SendKeys "^{g}", 3
No funciona, y creo que la única forma es hacerlo con SendMessage o con PostMessage, pero hay me pierdo.

[okik]

Hola  

En un Form crea un Botón (CommandButton)


Mete esto en un Módulo:

Código (vb) [Seleccionar] Expandir


Option Explicit
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long

'Funcición API para enviar un mensaje a MSPaint
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Const SC_CLOSE = &HF060&
Const WM_COMMAND = &H111
Const WM_SYSCOMMAND = &H112

'Función API para obtener el nombre de un archivo a partir de un directorio
Private Declare Function GetFileTitle Lib "comdlg32.dll" Alias "GetFileTitleA" _
(ByVal lpszFile As String, _
ByVal lpszTitle As String, _
ByVal cbBuf As Integer) As Integer

'Función para deternimnar si un proceso es una ventana
Private Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
'Función para obtener el nombre corto de un directorio
Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" _
(ByVal lpszLongPath As String, _
ByVal lpszShortPath As String, _
ByVal cchBuffer As Long) As Long


Public Const MS_SAVE = 0
Public Const MS_SAVE_AS = 1
Dim hwMsPaint As Long 'para el Handle de MsPaint

Public Function GetDirCorto(strPath) As String
Dim ShortName As String * 255
Call GetShortPathName(strPath, ShortName, 255)
GetDirCorto = Left$(ShortName, InStr(1, ShortName, Chr$(0)) - 1)
End Function


'Inicia MsPaint en modo oculto
Public Function StartMSPaint(ByVal PathMsPaint As String, ByVal strPathFile As String, ByVal Modo As Integer)
   On Error GoTo Error_sub
   Dim Count As Long
   Dim objStartup      As Object
   Dim objWMIService   As Object
   Dim objConfig       As Object
   Dim objProcess      As Object
   Dim Error           As Integer
   Dim strComputer     As String
   Dim intProcessID    As Long
   Dim Opcion          As Integer
   Dim sFile           As String
   Dim sDir            As String
   
   strComputer = "."
   hwMsPaint = 0
   Set objWMIService = GetObject("winmgmts:" _
   & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
   Set objStartup = objWMIService.Get("Win32_ProcessStartup")
   Set objConfig = objStartup.SpawnInstance_
   objConfig.ShowWindow = 12 'Iniciar en modo oculto (usar 1 para modo visible)
   Set objProcess = GetObject("winmgmts:root\cimv2:Win32_Process")
   
   sDir = GetDirCorto(strPathFile) 'Obtiene el directorio corto Ej.: "[Drive]:\Name~1.jpg"
       'Si el archivo no existe...
       If sDir = "" Then
           MsgBox "No se encuentra " & strPathFile, vbCritical
           Exit Function
       End If
       
   Error = objProcess.Create(PathMsPaint & " " & sDir, Null, objConfig, intProcessID)
       If Error Then
           MsgBox "No se encuentra " & PathMsPaint & "." & vbCrLf & vbCrLf & _
           "Compruebe que la aplicación existe o está correctamente escrito.", _
vbCritical, "Error"
           Exit Function
       End If
   
   'On Local Error Resume Next
   'Elimina las variables de objeto
   Set objStartup = Nothing
   Set objWMIService = Nothing
   Set objConfig = Nothing
   Set objProcess = Nothing
   
   'Obtiene el título del archivo a guardar
   sFile = gFileTitle(strPathFile)

   'Obtiene el handle de MSPaint que ha abierto el archivo
   Do While hwMsPaint = 0
       Count = Count + 1
       hwMsPaint = FindWindow("MSPaintApp", sFile & " - Paint")
       DoEvents
       If Count > 50000 Then Exit Function
   Loop
   
   'No pasa hasta el siguiente comando hasta que MsPaint se haya abierto
   Dim n&
   Do While n& = 1
       n& = IsWindow(hwMsPaint)
       DoEvents
   Loop
   
   'Envia el mensaje Guardar o Guardar como a MsPaint
   Call MsPaintSave(Modo)

   Do While n& = 0
   n& = IsWindow(hwMsPaint)
   CloseMsPaint
   DoEvents
   Loop
   
   Exit Function
     
Error_sub:
   MsgBox Err.Description, vbCritical

   On Local Error Resume Next
   'Elimina las variables de objeto
   
   Set objStartup = Nothing
   Set objWMIService = Nothing
   Set objConfig = Nothing
   Set objProcess = Nothing
End Function
 
Private Sub MsPaintSave(ByVal Modo As Integer)
Select Case Modo
Dim X&
Case 0
X& = SendMessage(hwMsPaint, WM_COMMAND, 57603, &H0) 'Guardar
Case 1
X& = SendMessage(hwMsPaint, WM_COMMAND, 57604, &H0) 'Guardar como...
End Select

End Sub

'Cierra MsPaint
Public Function CloseMsPaint()
'Envía el mensaje de Cerrar a MSPaint
SendMessage hwMsPaint, WM_SYSCOMMAND, SC_CLOSE, &H0
End Function

'Obtiene el nombre del archivo Ej.: E:\Paisaje.jpg" ->obtiene "Paisaje.jpg"
Private Function gFileTitle(ByVal strPathFile As String) As String
Dim strFileTitle As String
strFileTitle = Space(100)
GetFileTitle strPathFile, strFileTitle, 100
gFileTitle = Left$(strFileTitle, InStr(1, strFileTitle, Chr$(0)) - 1)
End Function





Mete esto en un Form:

Código (vb) [Seleccionar] Expandir



Private Sub Command1_Click()
Dim strFile As String
strFile = App.Path & "\Dock.jpg"

'MS_SAVE = Guardar (No aparecerá cuadro de diálogo)
'MS_SAVE_AS = Guardar como ...
Call StartMSPaint("mspaint.exe", strFile, MS_SAVE): CloseMsPaint

End Sub

Private Sub Form_Load()
Show
'Centrar formulario
Me.Move (Screen.Width / 2) - (Me.Width / 2), (Screen.Height / 2) - (Me.Height / 2)
Command1.Caption = "Guardar con MsPaint"
End Sub




Lo que hace...
1. Abre MSPaint en modo oculto (se ejecuta pero no se ve) con la imagen que quieras convertir. Mejor dicho, volver a guardar pero con MSPaint.

2.  Envía un mensaje a MSPaint mediante SendMessage. Que viene a ser el equivalente a pulsar "Guardar" o "Guardar como" del menú. (A elección)

3. Cierra MSPaint.

Download code:
https://mega.co.nz/#!WEllUYYB!JpyYKyzME3pBQc_Q9oZkoa4fnRGuapVAA19fM0Z98oQ

[Fran1946]

Hola okik:

Te agradezco mucho tu respuesta, y además con un código completo de programa.

Lo he probado y funciona perfectamente, pero no me soluciona el problema te explico:

Este programa llama al mspaint de windows, en su ruta original de 'System32', por lo tanto si yo ejecuto este programa en Win 7, ejecutara y cargará los archivos JPG en el maspaint de win 7, y este al salvar no disminuye nada el peso de los archivos JPG, que es el objeto de la aplicación.

Y el código que yo tengo en mi aplicación, ejecuta una copia de mspaint.exe de Win XP, que yo he renombrado como 'SDPaint.exe' que estaría en la ruta donde este el ejecutable de mi aplicación.
Por lo tanto si se ejecuta en Win 7, utiliza 'SDPaint.exe' , o sea la copia renombrada de mspaint de win XP, y no el mspaint de Win 7, y entonces si disminuye el peso de los archivos JPG.

Pero además he modificado la copia 'SDPaint.exe' con el editor hexadecimal WinHex, de forma que donde figura como 'MSPaintApp' ahora es 'SDPaintApp'.

Entonces en esta parte de tu código:

Código [Seleccionar] Expandir

'Obtiene el handle de MSPaint que ha abierto el archivo
    Do While hwMsPaint = 0
        Count = Count + 1
        hwMsPaint = FindWindow("MSPaintApp", sFile & " - Paint")
        DoEvents
        If Count > 50000 Then Exit Function
    Loop
  Entonces esta linea:

Código [Seleccionar] Expandir

hwMsPaint = FindWindow("MSPaintApp", sFile & " - Paint")

debería ser:

Código [Seleccionar] Expandir

hwMsPaint = FindWindow("SDPaintApp", sFile & " - Paint")

Pero no comprendo como trabaja esta parte de código que supongo carga mspaint:

Código [Seleccionar] Expandir


Set objWMIService = GetObject("winmgmts:" _
    & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
    Set objStartup = objWMIService.Get("Win32_ProcessStartup")
    Set objConfig = objStartup.SpawnInstance_
    objConfig.ShowWindow = 12 'Iniciar en modo oculto (usar 1 para modo visible)
    Set objProcess = GetObject("winmgmts:root\cimv2:Win32_Process")

    sDir = GetDirCorto(strPathFile) 'Obtiene el directorio corto Ej.: "[Drive]:\Name~1.jpg"

Y no se si se puede modificar para que cargue 'SDPaint.exe' , o sea la copia renombrada de mspaint de win XP.

Si esto fuera posible, entonces si me valdría.

Pero lo que si ha sido definitivo para que el código de mi proyecto, que si utiliza 'SDPaint.exe' , o sea la copia renombrada de mspaint de win XP, pueda salvar sin utilizar SendKeys, es esta linea de tu código:

Código [Seleccionar] Expandir

X& = SendMessage(hwMsPaint, WM_COMMAND, 57603, &H0) 'Guardar

Y por favor me puedes decir donde has conseguido saber que el parámetro 57603 es 'Guardar' y el 57604 es 'Guardar como', por que esto lo he buscado durante días en Internet y no he conseguido nada, y tengo un listado completo de constantes para SendMessage, y estos 2 parámetros no aparecen, este es el link:

http://www.vbcode.com/asp/showsn.asp?theID=11797

No se si me puedes responder a estas dudas, pero te doy las gracias de todas formas por tu ayuda.

Un saludo.

[okik]

Hola #Fran1946#

Me alegro que te haya funcionado correctamente. El cambio puede venir bien para otros usuarios que usen W7 y buen detalle lo de incluir el nombre de clase, que lógicamente cambia. Si quieres, además, si quieres usar otra versión que no se encuentre en el directorio del sistema, puedes poner el directorio:

Call StartMSPaint("C:\Directorio\mspaint.exe", strFile, MS_SAVE)


En cuanto al código  57603-'Guardar' y el 57604- 'Guardar como', hay  varias formas de obtenerlo. Una es extrayendo el menú mediante código o bien usando Spy++, pero es difícil de explicar.

Mediante código, puedes usar este, de prueba. Ejecuta SDPaint y con el paint abierto ejecuta este código.

Código (vb) [Seleccionar] Expandir

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function GetMenuString Lib "user32" Alias "GetMenuStringA" _
(ByVal hMenu As Long, _
ByVal wIDItem As Long, _
ByVal lpString As String, _
ByVal nMaxCount As Long, _
ByVal wFlag As Long) As Long

Private Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetMenuItemID Lib "user32" _
(ByVal hMenu As Long, ByVal nPos As Long) As Long
Private Declare Function GetSubMenu Lib "user32" _
(ByVal hMenu As Long, ByVal nPos As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
Const MF_BYPOSITION = &H400&
Const WM_COMMAND = &H111
Const MF_POPUP = &H10&



Private Sub Command1_Click()
   Dim hwnd As Long
   Dim hMainMenu As Long
   Dim hMenu As Long
   Dim MenuID As Long
   Dim szbuf As String * 128
   Dim szBufM As String * 128
   Dim I, Z
   Z = 0 'Posición del menú
   I = 2 'Posición del submenú
   hwnd = FindWindow("SDPaintApp", vbNullString)
   If hwnd = 0 Then Exit Sub
   hMainMenu = GetMenu(hwnd)
   hMenu = GetSubMenu(hMainMenu, Z)
   MenuID = GetMenuItemID(hMenu, I)
   Call GetMenuString(hMenu, MenuID, szbuf, 128, MF_BYPOSITION & MF_POPUP)

   MsgBox MenuID & "     " & szbuf
   
   'X& = SendMessage(hwnd, WM_COMMAND, MenuID, 0&)
   
End Sub


el valor Z representa el lugar del menú e I el lugar del submenú.

Puedes crear un bucle For/Next y repasar números del -1 al  1000 para I y de esa manera obtener todos los comandos.

[Fran1946]

Hola de nuevo okik:

Me encanta este código, lo he probado y me ha dado todos los wParam de los menues de Paint, solo he hecho un For-Next de 30 y me han sobrado.
Esto me va a servir de mucha ayuda para muchas cosas.

Sobre esto:

Código [Seleccionar] Expandir

Call StartMSPaint("C:\Directorio\mspaint.exe", strFile, MS_SAVE)

Así ya lo utilizaba en tu código, pero la desventaja es que cada archivo del ListBox que mando, carga un nuevo 'SDPaint', y eso lo quería evitar, quiero cargar solo en el primer archivo 'SDPaint' y luego mandarle los siguientes al mismo 'SDPaint' sin cerrar lo, pero en tu código no se si esto es posible, al menos yo no se donde hay que modificarlo.

El código para hacer esto, que me lo dado un usuario del foro de canalvisualbasic.net  que precisamente publico este post:

http://www.canalvisualbasic.net/foro/visual-basic-6-0/aporte-arrastrar-ficheros-sobre-una-ventana-21333/#post66767

Y con este código si se hace lo que quiero, pero no se podía salvar con SendKeys, por que lo que hace es Drag&Drop de los archivos a  un solo 'SDPaint' abierto, pero en memoria RAM.
Este código a mi me ha sorprendido, por que abarca todas las posibilidades, aunque yo solo utilizo una y ademas siempre consigue el hwnd de 'SDPaint', por que con:

Código [Seleccionar] Expandir

hwnd = FindWindow("SDPaintApp", vbNullString)

Falla mucho, y no siempre consigue el hwnd a la primera.

Y gracias a ti y a el, tengo lo necesario para lo que necesito.

Por cierto la imagen que adjuntas en el proyecto 'Dock.jpg' que pesa 309 Kb, con  'SDPaint', la reduce a 72.4 Kb un 76.6 % menos, aseguro que son exactamente iguales en resolución y calidad, pero no solo con JPG's de 72 ppp hace lo mismo con JPG's de 300 ppp, no me explico como Paint de XP consigue esto, que no se consigue con ningún otro programa, Photoshop hace justo lo contrario, aumenta el peso.

Te reitero una vez mas las gracias por tu ayuda.

Y si a ti o a alguien le interesa tener esta aplicación que lo diga en este post y yo publico o el link para descargar el ejecutable (60 Kb), o el código del proyecto.

Voy a hacer un vídeo para que se vea como utilizarlo, y lo subo aquí.

Un saludo.

[okik]

Quizás te interese este código. No es mío, es de un tal John Korejwa.  Puedes crear o convertir archivos JPG con diferentes niveles de compresión sin perder calidad. Es muy bueno, lo malo es que el como lo hace es muy complejo y resulta dificil de descifrar para luego modifiarlo y usarlo a tu manera. Utiliza módulos de clase y funciones GDI.


http://www.planet-source-code.com/vb/scripts/ShowCode.asp?txtCodeId=50065&lngWId=1

Enlace de descarga:
http://www.planet-source-code.com/vb/scripts/ShowZip.asp?lngWId=1&lngCodeId=50065&strZipAccessCode=tp%2FJ500653091