GDIplusCODE


'UserForm2 モジュール
Dim oldLeft As Long, oldTop As Long

Private Sub Frame1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  Dim xHm As Long, yHm As Long
  Dim ratio2 As Long
  Const lClick As Integer = 1
  
  ratio2 = 2
  If Button = lClick Then
    With renderArray(zoomLevel)
      xOffset = .xOffset + .xExtent * (X / Me.Frame1.Width) - .xExtent / (ratio2 * 2)
      'BitmapはPictureに対して上下鏡像の構造になっている事に注意
      yOffset = .yOffset - .yExtent + .yExtent * (Me.Frame1.Height - Y) / Me.Frame1.Height + .yExtent / (ratio2 * 2) '9000 'yExtent - yHm + yExtent / (ratio * 2)
      xExtent = .xExtent / ratio2
      yExtent = .yExtent / ratio2
    End With
    zoomLevel = zoomLevel + 1
    If UBound(renderArray) < zoomLevel Then ReDim Preserve renderArray(0 To zoomLevel)
    With renderArray(zoomLevel)
    .xOffset = xOffset
    .yOffset = yOffset
    .xExtent = xExtent
    .yExtent = yExtent
    End With
    Call renderPicture
  Else
    If zoomLevel > 0 Then
      zoomLevel = zoomLevel - 1
      With renderArray(zoomLevel)
        xOffset = .xOffset
        yOffset = .yOffset
        xExtent = .xExtent
        yExtent = .yExtent
      End With
    End If
    Call renderPicture
  End If
End Sub

Private Sub Frame1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  Call Hook
End Sub

'画面からはみ出した時の処理
Private Sub UserForm_Layout()
  If Abs(Me.Left - oldLeft) > 4 Or Abs(Me.Top - oldTop) > 4 Then Call renderPicture
  oldLeft = Me.Left
  oldTop = Me.Top
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
  Call Unhook
End Sub

Public Sub Hook()
    If Not IsHooked Then
      lpPrevWndProc = SetWindowLong(hFrame, GWL_WNDPROC, AddressOf WindowProc)
      IsHooked = True
    End If
End Sub

Public Sub Unhook()
    Dim temp As Long

    temp = SetWindowLong(hFrame, GWL_WNDPROC, lpPrevWndProc)
    IsHooked = False
End Sub

'☆　標準モジュール
Public Declare Function WindowFromAccessibleObject& Lib "oleacc" (ByVal pacc&, ByVal phwnd&)
Public Declare Function GetDC& Lib "user32" (ByVal hWnd&)
Public Declare Function ReleaseDC& Lib "user32" (ByVal hWnd&, ByVal hDC&)
Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Public Const GWL_WNDPROC = -4
Public Const WM_PAINT = &HF
Public Const WM_DESTROY = &H2
Public Const WM_NCHITTEST = &H84

Public IsHooked      As Boolean
Public lpPrevWndProc As Long
Public hWnd As Long
Public Pict As stdole.IPicture
Public hFrame As Long
Public ratio As Double
Public newWidth As Long, newHeight As Long
Public xOffset As Long, yOffset As Long, xExtent As Long, yExtent As Long
Public zoomLevel As Long
Public renderArray() As renderParam
Public FileName As String

Public Type renderParam
  xOffset As Long
  yOffset As Long
  xExtent As Long
  yExtent As Long
End Type

Sub zoomWithRender()
  Dim fFilter As String, fTitle As String
  
  fFilter = "JPEGファイル (*.jpg),*.jpg"
  fTitle = "ファイルを開く"
  FileName = Application.GetOpenFilename(fFilter, 1, fTitle)
  If FileName = "False" Then Exit Sub
  If UserForm2.Visible = False Then
    UserForm2.Show vbModeless
    If WindowFromAccessibleObject(ObjPtr(UserForm2.Frame1), VarPtr(hFrame)) Then Exit Sub
  End If
  Set Pict = LoadPicture(FileName)
  ratio = 0.8
  With UserForm2.Frame1
    newWidth = (96 * (Pict.Width / 100) / 25.4) * ratio
    newHeight = (96 * (Pict.Height / 100) / 25.4) * ratio
    .Width = (newWidth * 72 + 48) \ 96
    .Height = (newHeight * 72 + 48) \ 96
    .Parent.Width = .Width + 4.75
    .Parent.Height = .Height + 24.25
    .Caption = vbNullString
    .Top = 0
    .Left = 0
  End With
  UserForm2.Hook
  xOffset = 0: yOffset = Pict.Height: xExtent = Pict.Width: yExtent = Pict.Height
  zoomLevel = 0
  ReDim renderArray(0)
  With renderArray(0)
    .xOffset = xOffset
    .yOffset = yOffset
    .xExtent = xExtent
    .yExtent = yExtent
  End With
  Call renderPicture
End Sub

Sub renderPicture()
  Dim hDC As Long
  
  'Repaintは重要
  UserForm2.Frame1.Repaint
  hDC = GetDC(hFrame)
  If hDC = 0 Then Exit Sub
  Pict.Render hDC, 0, 0, newWidth, newHeight, xOffset, yOffset, xExtent, -yExtent, ByVal 0&
  ReleaseDC hFrame, hDC
  UserForm2.Hook
End Sub

Function WindowProc(ByVal hFrame As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Select Case uMsg
        Case WM_PAINT
          Call renderPicture
        'これが、Modelessフォーム対応のミソ
        'VBAが遅いので、WM_NCHITTESTなど一部のメッセージには対応できないそうな
        '処理しきれない速度のメッセージが来たら、一旦フックを解除してしまう
        Case WM_DESTROY, WM_NCHITTEST
          UserForm2.Unhook
        Case Else
    End Select
    WindowProc = CallWindowProc(lpPrevWndProc, hFrame, uMsg, wParam, lParam)
End Function
UserformのFrame上で画像を拡大・縮小表示
