Делимся наработками

Sub imgRotate(inFile As String, outFile As String, degreesRotate As Long) '90, 180, 270
    Dim Img As Object, IP As Object
    Set Img = CreateObject("WIA.ImageFile") 'create WIA objects
    Set IP = CreateObject("WIA.ImageProcess")
    IP.Filters.Add IP.FilterInfos("RotateFlip").filterid 'setup filter
    IP.Filters(1).Properties("RotationAngle") = degreesRotate
    Img.LoadFile inFile 'load image
    Set Img = IP.Apply(Img) 'apply change
    Img.SaveFile outFile 'save new image
End Sub

Sub imgFlip(inFile As String, outFile As String, Optional Horizontal As Boolean = True)
    Dim Img As Object, IP As Object
    Set Img = CreateObject("WIA.ImageFile") 'create WIA objects
    Set IP = CreateObject("WIA.ImageProcess")
    IP.Filters.Add IP.FilterInfos("RotateFlip").filterid 'setup filter
    IP.Filters(1).Properties("FlipHorizontal") = Horizontal
    IP.Filters(1).Properties("FlipVertical") = Not Horizontal
    Img.LoadFile inFile 'load image
    Set Img = IP.Apply(Img) 'apply change
    Img.SaveFile outFile 'save new image
End Sub

Sub imgResize(inFile As String, outFile As String, Optional maxWidth As Long, Optional maxHeight As Long, Optional KeepAspect As Boolean = True)
'if KeepAspect = True then both maxWidth and maxHeight must be specified
    Dim Img As Object, IP As Object
    Set IP = CreateObject("WIA.ImageProcess") 'create WIA objects
    Set Img = CreateObject("WIA.ImageFile")
    Img.LoadFile inFile 'load image
    IP.Filters.Add IP.FilterInfos("Scale").filterid 'setup filter
    If maxWidth <> 0 Then IP.Filters(1).Properties("MaximumWidth") = maxWidth
    If maxHeight <> 0 Then IP.Filters(1).Properties("MaximumHeight") = maxHeight
    IP.Filters(1).Properties("PreserveAspectRatio") = KeepAspect
    Set Img = IP.Apply(Img) 'apply change
    Img.SaveFile outFile 'save image
End Sub

Sub imgCrop(inFile As String, outFile As String, left As Long, top As Long, right As Long, bottom As Long)
    Dim Img As Object, IP As Object
    Set IP = CreateObject("WIA.ImageProcess") 'create WIA objects
    Set Img = CreateObject("WIA.ImageFile")
    Img.LoadFile inFile 'load image
    IP.Filters.Add IP.FilterInfos("Crop").filterid 'setup filter
    With IP.Filters(1)
        .Properties("Left") = Img.Width \ 4
        .Properties("Top") = Img.Height \ 4
        .Properties("Right") = Img.Width \ 4
        .Properties("Bottom") = Img.Height \ 4
    End With
    Set Img = IP.Apply(Img) 'apply change
    Img.SaveFile outFile 'save image
End Sub

Private Const WH_KEYBOARD_LL = 13&     'enables monitoring of keyboard
                                       'input events about to be posted
                                       'in a thread input queue
                                       
Private Const HC_ACTION = 0&           'wParam and lParam parameters
                                       'contain information about a
                                       'keyboard message
 
Private Const LLKHF_EXTENDED = &H1&    'test the extended-key flag
Private Const LLKHF_INJECTED = &H10&   'test the event-injected flag
Private Const LLKHF_ALTDOWN = &H20&    'test the context code
Private Const LLKHF_UP = &H80&         'test the transition-state flag
 
Private Const VK_TAB = &H9             'virtual key constants
Private Const VK_CONTROL = &H11
Private Const VK_ESCAPE = &H1B
 
Private Type KBDLLHOOKSTRUCT
  vkCode As Long        'a virtual-key code in the range 1 to 254
  scanCode As Long      'hardware scan code for the key
  flags As Long         'specifies the extended-key flag,
                        'event-injected flag, context code,
                        'and transition-state flag
  time As Long          'time stamp for this message
  dwExtraInfo As Long   'extra info associated with the message
End Type
 
Private Declare Function SetWindowsHookEx Lib "user32" _
   Alias "SetWindowsHookExA" _
  (ByVal idHook As Long, _
   ByVal lpfn As Long, _
   ByVal hmod As Long, _
   ByVal dwThreadId As Long) As Long
   
Private Declare Function UnhookWindowsHookEx Lib "user32" _
  (ByVal hHook As Long) As Long
 
Private Declare Function CallNextHookEx Lib "user32" _
  (ByVal hHook As Long, _
   ByVal nCode As Long, _
   ByVal wParam As Long, _
   ByVal lParam As Long) As Long
   
Private Declare Sub CopyMemory Lib "kernel32" _
   Alias "RtlMoveMemory" _
  (pDest As Any, _
   pSource As Any, _
   ByVal cb As Long)
 
Private Declare Function GetAsyncKeyState Lib "user32" _
   (ByVal vKey As Long) As Integer
 
Private m_hDllKbdHook As Long  'private variable holding
                               'the handle to the hook procedure
 
'---------------------------------------------------------------------------------------
' Procedure : Main
' Author    : Lord Orvell
'---------------------------------------------------------------------------------------
'
Public Sub Main()
 
  'set and obtain the handle to the keyboard hook
   m_hDllKbdHook = SetWindowsHookEx(WH_KEYBOARD_LL, _
                                   AddressOf LowLevelKeyboardProc, _
                                   App.hInstance, _
                                   0&)
  
  If m_hDllKbdHook <> 0 Then
  
     'It's hooked! Show a messagebox
     'to temporarily suspend the app here
     '(the LowLevelKeyboardProc will continue
     'to process messages), and follow the
     'messagebox, for this demo, with the
     'unhook call. See the text above for
     'specific information.
      MsgBox "Ctrl+Esc, Alt+Tab and Alt+Esc are blocked. " & _
             "Click OK to quit and re-enable the keys.", _
             vbOKOnly Or vbInformation, _
             "Keyboard Hook Active"
     
     'Placement for this demo only.
     'Move to the unload event of the
     'main form when used in an application.
      Call UnhookWindowsHookEx(m_hDllKbdHook)
      
   Else
      
      MsgBox "Failed to install low-level keyboard hook - " & Err.LastDllError
 
  End If
  
End Sub
 
 
'---------------------------------------------------------------------------------------
' Procedure : LowLevelKeyboardProc
' Author    : Lord Orvell
'---------------------------------------------------------------------------------------
'
Public Function LowLevelKeyboardProc(ByVal nCode As Long, _
                                     ByVal wParam As Long, _
                                     ByVal lParam As Long) As Long
 
  'Application-defined callback function
  'used with the SetWindowsHookEx function.
  'The system calls this function every
  'time a new keyboard input event is about
  'to be posted into a thread input queue.
  'The keyboard input can come from the local
  'keyboard driver or from calls to the
  'keybd_event function. If the input comes
  'from a call to keybd_event, the input
  'was "injected".
 
   Static kbdllhs As KBDLLHOOKSTRUCT
  
  'If nCode is less than zero, the hook
  'procedure must return the value returned
  'by CallNextHookEx.
  '
  'If nCode is greater than or equal to zero,
  'and the hook procedure did not process the
  'message, it is highly recommended that you
  'call CallNextHookEx and return the value it
  'returns; otherwise, other applications that
  'have installed WH_KEYBOARD_LL hooks will not
  'receive hook notifications and may behave
  'incorrectly as a result.
  '
  'If the hook procedure processed the message,
  'it may return a nonzero value to prevent the
  'system from passing the message to the rest
  'of the hook chain or the target window procedure.
    
   
   If nCode = HC_ACTION Then
   
     'nCode specifies a code the hook
     'procedure uses to determine how
     'to process the message. HC_ACTION
     'is the only valid code.
     
     'On receipt of the HC_ACTION code,
     'wParam and lParam contain information
     'about a keyboard message, and lParam
     'holds the pointer to a KBDLLHOOKSTRUCT
     'structure.
      Call CopyMemory(kbdllhs, ByVal lParam, Len(kbdllhs))
 
     'Ctrl+Esc --------------
      If (kbdllhs.vkCode = VK_ESCAPE) And _
          CBool(GetAsyncKeyState(VK_CONTROL) _
          And &H8000) Then
        Debug.Print "Ctrl+Esc blocked"
        LowLevelKeyboardProc = 1
        Exit Function
      End If  'kbdllhs.vkCode = VK_ESCAPE
        
     'Alt+Tab --------------
      If (kbdllhs.vkCode = VK_TAB) And _
          CBool(kbdllhs.flags And _
          LLKHF_ALTDOWN) Then
        Debug.Print "Alt+Tab blocked"
        LowLevelKeyboardProc = 1
        Exit Function
      End If  'kbdllhs.vkCode = VK_TAB
    
     'Alt+Esc --------------
      If (kbdllhs.vkCode = VK_ESCAPE) And _
          CBool(kbdllhs.flags And _
          LLKHF_ALTDOWN) Then
        Debug.Print "Alt+Esc blocked"
        LowLevelKeyboardProc = 1
        Exit Function
      End If  'kbdllhs.vkCode = VK_ESCAPE
   End If  'nCode = HC_ACTION
  
  LowLevelKeyboardProc = CallNextHookEx(m_hDllKbdHook, _
                                        nCode, _
                                        wParam, _
                                        lParam)
  
End Function

Option Compare Database
Option Explicit
 
Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" ( _
   ByVal hWnd As Long, lpdwProcessId As Any) As Long
 
Private Declare Function GetModuleHandle Lib "kernel32" _
   Alias "GetModuleHandleA" ( _
   ByVal lpModuleName As String) As Long
 
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
   pDest As Any, pSource As Any, ByVal cb As Long)
 
Private Const WH_KEYBOARD_LL = 13&     'enables monitoring of keyboard
                                       'input events about to be posted
                                       'in a thread input queue
 
Private Const HC_ACTION = 0&           'wParam and lParam parameters
                                       'contain information about a
                                       'keyboard message
 
Private Type KBDLLHOOKSTRUCT
   vkCode As Long        'a virtual-key code in the range 1 to 254
   scanCode As Long      'hardware scan code for the key
   flags As Long         'specifies the extended-key flag,
                         'event-injected flag, context code,
                         'and transition-state flag
   time As Long          'time stamp for this message
   dwExtraInfo As Long   'extra info associated with the message
End Type
 
Private Const LLKHF_ALTDOWN = &H20&    'test the context code
 
Private Declare Function SetWindowsHookEx Lib "user32" _
   Alias "SetWindowsHookExA" ( _
   ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, _
   ByVal dwThreadId As Long) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" ( _
   ByVal hHook As Long) As Long
Private Declare Function CallNextHookEx Lib "user32" ( _
   ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, _
   ByVal lParam As Long) As Long
 
Private m_hLLKbdHook As Long  'private variable holding
                              'the handle to the hook procedure
Private m_AccAppProcessId As Long
 
'----------------------------------------------------------------------------
' Procedure : BlockAltF4
' DateTime  : 12.03.2008
' Author    : Бенедикт
' Purpose   : Блокировка сочетания клавишь Alt+F4
'----------------------------------------------------------------------------
'
Public Sub BlockAltF4()
 If m_hLLKbdHook Then
    Debug.Print "Low level keyboard hook already installed!"
    Exit Sub
 End If
 
 GetWindowThreadProcessId Application.hWndAccessApp, m_AccAppProcessId
 
 'set and obtain the handle to the keyboard hook
 m_hLLKbdHook = SetWindowsHookEx(WH_KEYBOARD_LL, _
                                 AddressOf LowLevelKeyboardProc, _
                                 GetModuleHandle(vbNullString), _
                                 0&)
 If m_hLLKbdHook Then
    Debug.Print "Alt+F4 blocked."
 Else
    MsgBox "Failed to install low-level keyboard hook - " & Err.LastDllError
 End If
End Sub
 
'----------------------------------------------------------------------------' Procedure : UnblockAltF4
' DateTime  : 12.03.2008
' Author    : Бенедикт
' Purpose   : Разблокировка сочетания клавишь Alt+F4
'----------------------------------------------------------------------------
'
Public Sub UnblockAltF4()
 If m_hLLKbdHook Then
    UnhookWindowsHookEx m_hLLKbdHook
    m_hLLKbdHook = 0
    Debug.Print "Alt+F4 unblocked."
 End If
End Sub
 
'----------------------------------------------------------------------------
'
Public Function LowLevelKeyboardProc(ByVal nCode As Long, _
                                     ByVal wParam As Long, _
                                     ByVal lParam As Long) As Long
 'Application-defined callback function
 'used with the SetWindowsHookEx function.
 'The system calls this function every
 'time a new keyboard input event is about
 'to be posted into a thread input queue.
 'The keyboard input can come from the local
 'keyboard driver or from calls to the
 'keybd_event function. If the input comes
 'from a call to keybd_event, the input
 'was "injected".
 Debug.Print "LowLevelKeyboardProc", nCode, wParam, Hex$(lParam)
 
 Dim kbdllhs As KBDLLHOOKSTRUCT
 
 'If nCode is less than zero, the hook
 'procedure must return the value returned
 'by CallNextHookEx.
 '
 'If nCode is greater than or equal to zero,
 'and the hook procedure did not process the
 'message, it is highly recommended that you
 'call CallNextHookEx and return the value it
 'returns; otherwise, other applications that
 'have installed WH_KEYBOARD_LL hooks will not
 'receive hook notifications and may behave
 'incorrectly as a result.
 '
 'If the hook procedure processed the message,
 'it may return a nonzero value to prevent the
 'system from passing the message to the rest
 'of the hook chain or the target window procedure.
 
 If nCode = HC_ACTION Then
 
    'nCode specifies a code the hook
    'procedure uses to determine how
    'to process the message. HC_ACTION
    'is the only valid code.
 
    'On receipt of the HC_ACTION code,
    'wParam and lParam contain information
    'about a keyboard message, and lParam
    'holds the pointer to a KBDLLHOOKSTRUCT
    'structure.
     CopyMemory kbdllhs, ByVal lParam, Len(kbdllhs)
 
     'Alt+F4 --------------
     If (kbdllhs.vkCode = vbKeyF4) And (kbdllhs.flags And LLKHF_ALTDOWN) Then
        Dim ForeProcessId As Long
        GetWindowThreadProcessId GetForegroundWindow, ForeProcessId
 
        If m_AccAppProcessId = ForeProcessId Then
           Debug.Print "Alt+F4 blocked."
           LowLevelKeyboardProc = 1
           Exit Function
        End If
     End If  'kbdllhs.vkCode = VK_F4
  End If  'nCode = HC_ACTION
 
 LowLevelKeyboardProc = CallNextHookEx(m_hLLKbdHook, nCode, wParam, lParam)
End Function

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
   If KeyCode = vbKeyF4 And Shift = acAltMask Then KeyCode = 0 'отключить Alt+F4
   If KeyCode = vbKeyF4 And Shift = acShiftMask Then KeyCode = 0 'отключить Shift+F4
   If KeyCode = vbKeyF4 And Shift = acCtrlMask Then KeyCode = 0 'отключить Ctrl+F4
   If KeyCode = vbKeyW And Shift = acCtrlMask Then KeyCode = 0 'отключить Ctrl+W
End Sub

    Dim cWIA                  As New cls_WIA
 
    With cWIA
        .InputFile = "C:\Temp\Landscape_3.jpg"
 
        ' Access the WIA objects and filters count
        With .ImageFile
            Debug.Print .Width
            Debug.Print .Height
            Debug.Print .HorizontalResolution
            Debug.Print .VerticalResolution
            Debug.Print .IsAnimated
            Debug.Print .ActiveFrame
            Debug.Print .FrameCount
            Debug.Print .FileExtension
            Debug.Print .IsAlphaPixelFormat
            Debug.Print .PixelDepth
            Debug.Print .FormatID
            Debug.Print .IsExtendedPixelFormat
            Debug.Print .IsIndexedPixelFormat
        End With
 
        .Clear
    End With
 
    Set cWIA = Nothing

    Dim cWIA              As New cls_WIA
 
    With cWIA
        .InputFile = "C:\Temp\Landscape_3.jpg"
        .OutputFile = "C:\Temp\Landscape_3_rotated.jpg"
 
        .Rotate 180
        .ApplyFilters
 
        .Save
        .Clear
    End With
    
    Set cWIA = Nothing

    Dim cWIA                  As New cls_WIA
 
    With cWIA
        .InputFile = "C:\Temp\Landscape_3.jpg"
        .OutputFile = "C:\Temp\Landscape_3.bmp"
 
        .ConvertImage wiaFormatBMP
        .ApplyFilters
 
        .Save
        .Clear
    End With
 
    Set cWIA = Nothing

   Dim cWIA                  As New cls_WIA
 
    With cWIA
        .InputFile = "C:\Temp\Landscape_3.jpg"
        .OutputFile = "C:\Users\Dev\Desktop\MyPic.png"
 
        .AutoOrient
        .Resize 300, 300, True
        .ConvertImage wiaFormatPNG
        .ApplyFilters
 
        .Save
        .Clear
    End With
 
    Set cWIA = Nothing

Me.ImageControlName.PictureData = .GetBinaryData

    Dim cWIA                  As New cls_WIA
 
    With cWIA
        .InputFile = "C:\Temp\Landscape_3.jpg"
        .OutputFile = "C:\Users\Dev\Desktop\MyPic.png"
 
        .AutoOrient
        .Resize 300, 300, True
        .ConvertImage wiaFormatPNG
        .ApplyFilters
 
        Me.ImageControlName.PictureData = .GetBinaryData
    End With
 
    Set cWIA = Nothing