VBAからGDI+を使う資料集
inet上の達人の方々から御教示いただいたコードを少しアレンジさせてもらっています（切り貼りとも言います）。
  1. ホーム
  2. Other
  3. 画像をD&D/セル編集制御


Sheetを覆う透明Userformに画像ドロップ/セル編集を疑似トラップ - 枠無しUserFormで遊んでみた

1.エクスプローラーやVix等で表示した画像のリストから、エクセルワークシートに画像ファイルをドラッグ&ドロップします。 透過率を上げたUserFormでエクセルのワークシート領域を覆い、ドラッグ＆ドロップを受け入れます。 GDI+の項でExcel自体のウィンドウをサブクラス化した代わりです。
リンク→エクスプローラ等から画像ファイルをワークシートにD&D・縮小回転機能付き【XL2010一応OK】

2.セルのSelectionChangeで同じサイズのUserFormを上に表示し、セル編集を肩代わりします。 セル編集中はVBAの制御が及ばないので、なんとか制御してやろうという案です。 Q&Aサイトの数値の頭に0を付けて入力したときと、付けない時で処理を変えたいというお題に対する大げさすぎる回答が元です。

注）上記二つとも、ウィンドウ枠の固定や、画面分割には対応していません。ウィンドウ枠を固定すると、固定幅分のズレが発生する様です。 


'=============================================================
１．.エクスプローラーやVixから、エクセルワークシートに画像ファイルをドラッグ&ドロップ。

'☆UserForm1モジュール
UserFrom1には何も置かない。
Option Explicit

Dim R1C1Left As Long
Dim R1C1Top As Long

Private Sub UserForm_Initialize()
  'フォームの不透明度 0にすると機能しなくなる。1ならほとんど判別できないが機能する。
  '100程度の半透明グレイにして、サブクラス化している事を明示＋文字も表示する方が分かり易いかもしれません。
  Const opacityRatio As Long = 1

  With Me
    .StartUpPosition = 0
    .BorderStyle = fmBorderStyleNone
    .SpecialEffect = fmSpecialEffectFlat
    'フォームに時刻を名前としてつける
    .Caption = .Caption & Timer()
  End With
  '名前を手がかりとして、ユーザーフォームのハンドルを取得
  m_hwnd = FindWindow("ThunderDFrame", Me.Caption)
  ' フォームのメニュー、最大最小化ボタン等は一切表示しない設定とする
  SetWindowLong m_hwnd, GWL_STYLE, _
              GetWindowLong(m_hwnd, GWL_STYLE) And _
                       Not (WS_SYSMENU Or WS_CAPTION Or _
                            WS_MINIMIZEBOX Or WS_MAXIMIZEBOX)
  SetWindowLong m_hwnd, GWL_EXSTYLE, _
              GetWindowLong(m_hwnd, GWL_EXSTYLE) And _
              Not WS_EX_DLGMODALFRAME
  SetWindowLong m_hwnd&, GWL_EXSTYLE, _
            GetWindowLong(m_hwnd&, GWL_EXSTYLE) Or WS_EX_LAYERED
  SetLayeredWindowAttributes m_hwnd&, 0, opacityRatio, LWA_ALPHA
              
  'ドラッグ＆ドロップ受け入れ有
  Call DragAcceptFiles(m_hwnd, True)

  R1C1Left = ActiveWindow.PointsToScreenPixelsX(0)
  R1C1Top = ActiveWindow.PointsToScreenPixelsY(0)
End Sub

Private Sub UserForm_Activate()
  Dim myLeft As Long, myTop As Long, myWidth As Long, myHeight As Long
  Dim zoomX As Single, zoomY As Single
  Dim rightBottomCell As Range
  Const myFontSize = 11
   
  'エクセルのActiveWindowのセルが表示されている範囲を覆うUserFormを表示
  'ほとんど透明なので視認できない
  realZoomRate zoomX, zoomY
  With Application.ActiveWindow.VisibleRange
    Set rightBottomCell = .Cells(.Rows.Count, .Columns.Count)
  End With
  myLeft = R1C1Left
  myTop = R1C1Top
  myWidth = zoomX * (rightBottomCell.Left + rightBottomCell.Width) * DPI / PPI
  myHeight = zoomY * (rightBottomCell.Top + rightBottomCell.Height) * DPI / PPI
  
  'フォームの表示順（Zオーダー）、サイズ指定
  SetWindowPos m_hwnd, HWND_TOP, myLeft, myTop, myWidth, myHeight, SWP_FRAMECHANGED
  Hook
errHandle:
End Sub
 
'画像ドロップをやめたくなったときは何かキーを押すと停止
Private Sub UserForm_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
  Unload Me
End Sub

'UserForm終了時にループを止める。
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
  Unhook
End Sub

'念のため。
Private Sub UserForm_Terminate()
  On Error Resume Next
  Unhook
End Sub


'☆標準モジュール Module1

Sub showForm()
  UserForm1.Show
End Sub


'☆標準モジュール Module2
'AddressOfが使えるのは標準モジュールのプロシージャのみ。

Option Explicit
'マクロ一覧で表示されなくする
Option Private Module
 
Type POINTAPI
    x As Long
    y As Long
End Type

'ウィンドウのハンドル取得
Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
'指定されたウィンドウプロシージャに、メッセージ情報を渡します
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
'ウィンドウに関しての情報を取得
Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
'指定されたウィンドウの属性を変更
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
'ウィンドウのサイズ、位置、および Z オーダーを変更
Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal uFlags As Long) As Long
'ウィンドウがファイルのドラッグアンドドロップを受け入れるかどうかを設定
Declare Sub DragAcceptFiles Lib "Shell32.dll" (ByVal hwnd As Long, ByVal fAccept As Long)
'ドラッグアンドドロップ操作が成功した場合、ドロップされたファイルの名前を取得する
Declare Function DragQueryFile Lib "Shell32.dll" Alias "DragQueryFileA" (ByVal hDrop As Long, ByVal UINT As Long, ByVal lpStr As String, ByVal ch As Long) As Long
'アプリケーションへファイル名を転送するためにシステムが割り当てたメモリを解放
Declare Sub DragFinish Lib "Shell32.dll" (ByVal hDrop As Long)
'ファイルがドラッグ・アンド・ドロップされたときのマウスポインタの位置を取得
Declare Function DragQueryPoint Lib "Shell32.dll" (ByVal hDrop As Long, lpPoint As POINTAPI) As Long
'クライアント座標→スクリーン座標への変換
Declare Function ClientToScreen Lib "user32.dll" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
'Windowを半透明化する
Public Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd&, ByVal crKey As Long, ByVal bAlpha As Long, ByVal dwFlags As Long) As Long

Public Const LWA_COLORKEY = 1
Public Const LWA_ALPHA = 2
                
Public Const SM_CXSCREEN As Long = 0
Public Const SM_CYSCREEN As Long = 1
Public Const GWL_STYLE = -16
Public Const GWL_EXSTYLE = -20
Public Const WS_CAPTION = &HC00000 'タイトルバーを持つウィンドウ
Public Const WS_SYSMENU = &H80000  'タイトルバー上にウィンドウメニューボックスを持つウィンドウ
Public Const WS_MINIMIZEBOX = &H20000 '最小化ボタンを持つウィンドウ
Public Const WS_MAXIMIZEBOX = &H10000  '最大化ボタンを持つウィンドウ
Public Const WS_EX_DLGMODALFRAME = &H1&    '二重の境界線を持つウィンドウ
Public Const HWND_TOPMOST = -1&   '常に手前に表示
Public Const HWND_TOP = 0         '手前に表示
Public Const SWP_FRAMECHANGED = &H20
Public Const WM_DROPFILES = &H233
Public Const GWL_WNDPROC = -4
Public Const WS_EX_TOOLWINDOW = &H80
Public Const WS_EX_LAYERED = &H80000
Public Const WM_KEYDOWN = &H100

'スクリーン座標とエクセルワークシート座標の変換
'出典：http://home.att.ne.jp/zeta/gen/excel/c04p06.htm
Public Const DPI As Long = 96
Public Const PPI As Long = 72

Public IsHooked      As Boolean
Public lpPrevWndProc As Long
Public m_hwnd         As Long

'画像の縮尺率 テスト用に決め打ち。テスト用なのでGDI+による縮小は行わず、簡易処理。
Const resizeRatio As Double = 0.25
 
'----------------------------------------------------------------
'ウィンドウプロシージャ
'----------------------------------------------------------------
Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim hDrop   As Long
    Dim filecnt As Long         'ファイルの総数
    Dim files() As String       'ファイル名
    Dim i       As Long
    Dim leng    As Long
    Dim buf     As String * 256
    Dim pDrop   As POINTAPI
    Dim pScrn   As POINTAPI
    
    On Error Resume Next 'フリーズ防止に必要
    Select Case uMsg
        Case WM_DROPFILES   'ドロップされた
            '---------------------------------------
            'ドラッグされたファイルの格納
            '---------------------------------------
            hDrop = wParam
            'ドラッグされたファイル数の取得
            filecnt = DragQueryFile(hDrop, -1&, vbNullString, 0)
            'ドロップされた位置の取得
            Call DragQueryPoint(hDrop, pDrop)
            pScrn = pDrop
            Call ClientToScreen(m_hwnd, pScrn)
            
            '配列初期化
            ReDim files(filecnt - 1)
            'ファイル名の取得
            For i = 0 To filecnt - 1
                '変数初期化
                buf = String(256, Chr(0))   'nullで埋める
                'ファイルの取得
                leng = DragQueryFile(hDrop, i, buf, 256)
                '取得結果を配列に格納
                files(i) = Left$(buf, InStr(1, buf, Chr(0)) - 1)
            Next
            'メモリの開放
            Call DragFinish(hDrop)
             'ドロップされた位置に該当するセルをActivate
            ActiveSheet.Range(screenToCellAddress(pScrn)).Activate
           
            With ActiveSheet.Pictures.Insert(files(0))
               .ShapeRange.LockAspectRatio = False
              .Top = ActiveCell.Top
              .Left = ActiveCell.Left
              '写真サイズの設定
              .Width = .Width * resizeRatio
              .Height = .Height * resizeRatio
              .Cut
            End With
            ActiveSheet.PasteSpecial Format:="図 (JPEG)", Link:=False, DisplayAsIcon:=False
            '安定しているので、連続貼り付けも可能です。
            'Unload UserForm1
        '効かない→UserForm側のkeypressイベントは有効であった
'        Case WM_KEYDOWN
'            Call DragFinish(hDrop)
'            Unload UserForm1
        Case Else
'            '他の処理はデフォルトのウィンドウプロシージャに委ねる
'            WindowProc = CallWindowProc(lpPrevWndProc, hwnd, uMsg, wParam, lParam)
    End Select
    'K窓さんに倣ってこちらに変更してみた
    '他の処理はデフォルトのウィンドウプロシージャに委ねる
    WindowProc = CallWindowProc(lpPrevWndProc, hwnd, uMsg, wParam, lParam)
End Function

'----------------------------------------------------------------
'サブクラス化開始
'　Publicにしないと、UserFormから参照できない
'----------------------------------------------------------------
Public Sub Hook()
    If IsHooked Then
        MsgBox "Don't hook it twice without " & _
            "unhooking, or you will be unable to unhook it."
    Else
        '受け入れの有
        Call DragAcceptFiles(m_hwnd, True)
        'ウィンドウプロシージャの登録
        lpPrevWndProc = SetWindowLong(m_hwnd, GWL_WNDPROC, AddressOf WindowProc)
        IsHooked = True
    End If
End Sub

'----------------------------------------------------------------
'サブクラス化解除
'----------------------------------------------------------------
Public Sub Unhook()
    Dim temp As Long

    '元のウィンドウプロシージャに戻す
    temp = SetWindowLong(m_hwnd, GWL_WNDPROC, lpPrevWndProc)
    '受け入れの無
    Call DragAcceptFiles(m_hwnd, True)
    IsHooked = False
End Sub

'ワークシート上のクリックより得られたスクリーン座標をセル座標に変換する
Public Function screenToCellAddress(scrnPOINT As POINTAPI) As String
    Dim pointDifX As Single, pointDifY As Single
    Dim startX As Single, startY As Single
    Dim targetRange As Range
    Dim pointX As Single, pointY As Single
    Dim zoomX As Single, zoomY As Single
    Dim i As Long
  
    '左上隅セルの左上角との距離をポイントに変換
    Call realZoomRate(zoomX, zoomY)
    pointDifX = (scrnPOINT.x - ActiveWindow.PointsToScreenPixelsX(0)) * PPI / DPI / zoomX
    pointDifY = (scrnPOINT.y - ActiveWindow.PointsToScreenPixelsY(0)) * PPI / DPI / zoomY
    startX = ActiveWindow.VisibleRange(1).Left
    startY = ActiveWindow.VisibleRange(1).Top
    Set targetRange = ActiveWindow.VisibleRange(1)
    For i = 1 To ActiveWindow.VisibleRange(1).Column
        pointX = pointX + targetRange.Width
    Next i
    For i = 1 To ActiveWindow.VisibleRange(1).Row
        pointY = pointY + targetRange.Height
    Next i
    Do Until pointX > pointDifX
        Set targetRange = targetRange.Offset(0, 1)
        pointX = pointX + targetRange.Width
    Loop
    Do Until pointY > pointDifY
        Set targetRange = targetRange.Offset(1, 0)
        pointY = pointY + targetRange.Height
    Loop
    screenToCellAddress = targetRange.Address
End Function

'真のズーム倍率を求める 'by kanabunさん
Public Sub realZoomRate(ByRef zoomX As Single, ByRef zoomY As Single)
  Dim c As Range
  Dim dotX As Long
  Dim dotY As Long
  Dim dotX1 As Long
  Dim dotY1 As Long
  
  Set c = Range("a1")
  With ActiveWindow
    ' ---------- 実際のZoom比の計算 ---------------
    dotY = c.Height * DPI / PPI
    dotY1 = dotY * .Zoom / 100
    zoomY = dotY1 / dotY '実際に適用されているZoom率
    dotX = c.Width * DPI / PPI
    dotX1 = dotX * .Zoom / 100
    zoomX = dotX1 / dotX
  End With
End Sub

'=============================================================
２．セルと同じサイズのUserFormを上に表示し、セル編集を肩代わり。

'☆UserForm1モジュール
'TextBox一個を置く。位置、寸法はコードで設定しているので適当で可
'SelectionChangeイベントでセルと同サイズにリサイズしてセル上に表示。
'編集を中断したいときはESCキーを押す。

Private Declare Function SetWindowLong Lib "user32" _
        Alias "SetWindowLongA" _
        (ByVal hWnd As Long, ByVal nIndex As Long, _
        ByVal dwNewLong As Long) As Long
        
Private Declare Function GetWindowLong Lib "user32" _
        Alias "GetWindowLongA" _
        (ByVal hWnd As Long, ByVal nIndex As Long) As Long
        
Private Declare Function FindWindow Lib "user32" _
        Alias "FindWindowA" _
        (ByVal lpClassName As String, _
        ByVal lpWindowName As String) As Long

Private Declare Function SetWindowPos Lib "user32" _
        (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, _
        ByVal x As Long, ByVal y As Long, ByVal cx As Long, _
        ByVal cy As Long, ByVal uFlags As Long) As Long
        
Private Const SM_CXSCREEN As Long = 0
Private Const SM_CYSCREEN As Long = 1
Private Const GWL_STYLE = -16
Private Const GWL_EXSTYLE = -20
Private Const WS_CAPTION = &HC00000 'タイトルバーを持つウィンドウ
Private Const WS_SYSMENU = &H80000  'タイトルバー上にウィンドウメニューボックスを持つウィンドウ
Private Const WS_MINIMIZEBOX = &H20000 '最小化ボタンを持つウィンドウ
Private Const WS_MAXIMIZEBOX = &H10000  '最大化ボタンを持つウィンドウ
Private Const WS_EX_DLGMODALFRAME = &H1&    '二重の境界線を持つウィンドウ
Private Const HWND_TOPMOST = -1&   '常に手前に表示
Private Const HWND_TOP = 0         '手前に表示
Private Const SWP_FRAMECHANGED = &H20
'スクリーン座標とエクセルワークシート座標の変換
'出典：http://home.att.ne.jp/zeta/gen/excel/c04p06.htm
Private Const DPI As Long = 96
Private Const PPI As Long = 72

Dim m_hwnd As Long
Dim R1C1Left As Long
Dim R1C1Top As Long

Private Sub UserForm_Initialize()
  With Me
    .StartUpPosition = 0
    .BorderStyle = fmBorderStyleNone
    .SpecialEffect = fmSpecialEffectFlat
    'フォームに時刻を名前としてつける
    .Caption = .Caption & Timer()
  End With
  '名前を手がかりとして、ユーザーフォームのハンドルを取得
  m_hwnd = FindWindow("ThunderDFrame", Me.Caption)
  ' フォームのメニュー、最大最小化ボタン等は一切表示しない設定とする
  SetWindowLong m_hwnd, GWL_STYLE, _
              GetWindowLong(m_hwnd, GWL_STYLE) And _
                       Not (WS_SYSMENU Or WS_CAPTION Or _
                            WS_MINIMIZEBOX Or WS_MAXIMIZEBOX)
  SetWindowLong m_hwnd, GWL_EXSTYLE, _
              GetWindowLong(m_hwnd, GWL_EXSTYLE) And _
              Not WS_EX_DLGMODALFRAME
  With Me.TextBox1
    .Top = 0
    .Left = 0
    .Height = Me.InsideHeight
    .Width = Me.InsideWidth
    .SpecialEffect = fmSpecialEffectFlat
    .BorderStyle = fmBorderStyleNone
    .Value = ActiveCell.Value
  End With

  R1C1Left = ActiveWindow.PointsToScreenPixelsX(0)
  R1C1Top = ActiveWindow.PointsToScreenPixelsY(0)
End Sub

Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
  Select Case KeyCode
    Case vbKeyReturn
      If IsNumeric(Me.TextBox1.Value) Then
        If CDbl(Me.TextBox1.Value) >= 1 Then
          If Left(Me.TextBox1.Value, 1) = "0" Then
              ActiveCell.Value = Format(Val(Me.TextBox1.Value), "#") & "K"
              '書式だけ KまたはC/S表示して、数値として残す場合。後々混乱するかも。
              'ActiveCell.Value = CDbl(Me.TextBox1.Value)
              'ActiveCell.NumberFormatLocal = "G/標準""K"""
          Else
              ActiveCell.Value = Me.TextBox1.Value & "C/S"
              'ActiveCell.Value = CDbl(Me.TextBox1.Value)
              'ActiveCell.NumberFormatLocal = "G/標準""C/S"""
          End If
        Else
          ActiveCell.Value = Me.TextBox1.Value
        End If
      Else
        ActiveCell.Value = Me.TextBox1.Value
      End If
      'Me.Hide
      Unload Me
    Case vbKeyEscape
      'アプリケーションのウィンドウサイズ変更のイベントが動かず、ズーム比変更のイベントも無いので
      'Hide->Unloadにしてみた
      'Me.Hide
      Unload Me
  End Select
    'お好みで
'    ActiveCell.Offset(1, 0).Activate
End Sub

Private Sub UserForm_Activate()
  Dim myLeft As Long, myTop As Long, myWidth As Long, myHeight As Long
  Dim zoomX As Single, zoomY As Single
  Const myFontSize = 11
   
'  myLeft = ((ActiveCell.Left * DPI / PPI) * (ActiveWindow.Zoom / 100)) + R1C1Left
'  myTop = ((ActiveCell.Top * DPI / PPI) * (ActiveWindow.Zoom / 100)) + R1C1Top

  realZoomRate zoomX, zoomY
  myLeft = ((ActiveCell.Left * DPI / PPI) * zoomX) + R1C1Left
  myTop = ((ActiveCell.Top * DPI / PPI) * zoomY) + R1C1Top
  myWidth = zoomX * ActiveCell.Width * DPI / PPI
  myHeight = zoomY * ActiveCell.Height * DPI / PPI
  'フォームの表示順（Zオーダー）、サイズ指定
  SetWindowPos m_hwnd, HWND_TOP, myLeft, myTop, myWidth, myHeight, SWP_FRAMECHANGED
  Me.TextBox1.Font.Size = Int(myFontSize * zoomY)
  Me.TextBox1.Value = ActiveCell.Value
End Sub

'真のズーム倍率を求める 'by kanabunさん
Private Sub realZoomRate(ByRef zoomX As Single, ByRef zoomY As Single)
  Dim c As Range
  Dim dotX As Long
  Dim dotY As Long
  Dim dotX1 As Long
  Dim dotY1 As Long
  
  Set c = Range("a1")
  With ActiveWindow
    ' ---------- 実際のZoom比の計算 ---------------
    dotY = c.Height * DPI / PPI
    dotY1 = dotY * .Zoom / 100
    zoomY = dotY1 / dotY '実際に適用されているZoom率
    dotX = c.Width * DPI / PPI
    dotX1 = dotX * .Zoom / 100
    zoomX = dotX1 / dotX
  End With
End Sub

'☆Sheet1モジュール
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  'とりえあずA列のみで動作する様にしてある
  If Target.Column <> 1 Then Exit Sub
  If Target.Cells.Count > 1 Then Exit Sub
  UserForm1.Show
End Sub

' Workbook_BeforeClose(Cancel As Boolean)にも入れて置く方が良いかも
Private Sub Worksheet_Deactivate()
  On Error Resume Next
  Unload UserForm1
End Sub