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
 
 

 
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
 
 

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