[Excel][VBA]エクセルでピザカッター（画像を等しい角度で分割）

0.README.md

[Excel][VBA]エクセルでピザカッター（画像を等しい角度で分割）

PowerPointで、丸い画像を強引に等分する方法というツイートを見て、エクセルでもやってみたくなったので。

こちらにはソースコードのみさらしてあります。マクロ有効ワークシートを共有してありますので、ダウンロードしてお試し下さい。
エクセルではVBAを使っても結構苦労したのですが、もっと簡単にできるよ！という方はぜひご教示下さいませ🙇

ソースコード

• メイン処理用標準モジュール
• クリップボード操作用モジュール
• 「ピザカッター」シート用Worksheetモジュール

Mod_Clipboard.vba

Option Explicit

' [Share the Clipboard with VBA and the Windows API - Francesco Foti's weblog](https://francescofoti.com/2013/12/share-the-clipboard-with-vba-and-the-windows-api/)
'[A clipboard object for VBA, including Microsoft Word](https://social.msdn.microsoft.com/Forums/sqlserver/en-US/ee9e0d28-0f1e-467f-8d1d-1a86b2db2878/a-clipboard-object-for-vba-including-microsoft-word?forum=worddev)

Const GMEM_ZEROINIT = &H40
Const GMEM_MOVEABLE = &H2
Const GHND = (GMEM_MOVEABLE Or GMEM_ZEROINIT)
Const NAME_MAX_LENGTH = 1024

#If Win64 Then
    'To copy text on the clipboard
    Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongLong) As Long
    Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongLong) As LongPtr
    Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As LongLong) As LongPtr
    Declare PtrSafe Function GlobalSize Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
    Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
    Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongLong) As Long
    Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
    Declare PtrSafe Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As Any, ByVal lpString2 As String) As LongPtr
    Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
    Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As LongLong) As LongLong
    Declare PtrSafe Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As Long
    Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
    Declare PtrSafe Function GetClipboardFormatName Lib "user32" Alias "GetClipboardFormatNameA" (ByVal wFormat As Long, ByVal lpString As String, ByVal nMaxCount As Long) As Long
#Else
    Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
    Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
    Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
    Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
    Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
    Declare Function CloseClipboard Lib "user32" () As Long
    Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
    Declare Function EmptyClipboard Lib "user32" () As Long
    Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
    Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
    Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
    Declare Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As Long
    Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
    Declare Function GetClipboardFormatName Lib "user32" Alias "GetClipboardFormatNameA" (ByVal wFormat As Long, ByVal lpString As String, ByVal nMaxCount As Long) As Long
#End If

Public Enum eCBFormat
    CF_TEXT = &H1
    CF_BITMAP = &H2
    CF_METAFILEPICT = &H3
    CF_SYLK = &H4
    CF_DIF = &H5
    CF_TIFF = &H6
    CF_OEMTEXT = &H7
    CF_DIB = &H8
    CF_PALETTE = &H9
    CF_PENDATA = &HA
    CF_RIFF = &HB
    CF_WAVE = &HC
    CF_UNICODETEXT = &HD
    CF_ENHMETAFILE = &HE
    CF_HDROP = &HF
    CF_LOCALE = &H10
    CF_MAX = &H11
    CF_OWNERDISPLAY = &H80
    CF_DSPTEXT = &H81
    CF_DSPBITMAP = &H82
    CF_DSPMETAFILEPICT = &H83
    CF_DSPENHMETAFILE = &H8E
    CF_PRIVATEFIRST = &H200
    CF_PRIVATELAST = &H2FF
    CF_GDIOBJFIRST = &H300
    CF_GDIOBJLAST = &H3FF
End Enum

Property Get CBFormatName(ByVal Value)
    Static ValueToName
    If IsEmpty(ValueToName) Then
        Set ValueToName = CreateObject("Scripting.Dictionary")
        ValueToName(CF_TEXT) = "CF_TEXT"
        ValueToName(CF_BITMAP) = "CF_BITMAP"
        ValueToName(CF_METAFILEPICT) = "CF_METAFILEPICT"
        ValueToName(CF_SYLK) = "CF_SYLK"
        ValueToName(CF_DIF) = "CF_DIF"
        ValueToName(CF_TIFF) = "CF_TIFF"
        ValueToName(CF_OEMTEXT) = "CF_OEMTEXT"
        ValueToName(CF_DIB) = "CF_DIB"
        ValueToName(CF_PALETTE) = "CF_PALETTE"
        ValueToName(CF_PENDATA) = "CF_PENDATA"
        ValueToName(CF_RIFF) = "CF_RIFF"
        ValueToName(CF_WAVE) = "CF_WAVE"
        ValueToName(CF_UNICODETEXT) = "CF_UNICODETEXT"
        ValueToName(CF_ENHMETAFILE) = "CF_ENHMETAFILE"
        ValueToName(CF_HDROP) = "CF_HDROP"
        ValueToName(CF_LOCALE) = "CF_LOCALE"
        ValueToName(CF_MAX) = "CF_MAX"
        ValueToName(CF_OWNERDISPLAY) = "CF_OWNERDISPLAY"
        ValueToName(CF_DSPTEXT) = "CF_DSPTEXT"
        ValueToName(CF_DSPBITMAP) = "CF_DSPBITMAP"
        ValueToName(CF_DSPMETAFILEPICT) = "CF_DSPMETAFILEPICT"
        ValueToName(CF_DSPENHMETAFILE) = "CF_DSPENHMETAFILE"
        ValueToName(CF_PRIVATEFIRST) = "CF_PRIVATEFIRST"
        ValueToName(CF_PRIVATELAST) = "CF_PRIVATELAST"
        ValueToName(CF_GDIOBJFIRST) = "CF_GDIOBJFIRST"
        ValueToName(CF_GDIOBJLAST) = "CF_GDIOBJLAST"
    End If
    If ValueToName.Exists(Value) Then
        CBFormatName = ValueToName(Value)
    Else
'        Dim WorkName: WorkName = String(NAME_MAX_LENGTH, vbNullChar)
'        Dim NameLen: NameLen = GetClipboardFormatName(Value, WorkName, Len(WorkName))
'        CBFormatName = IIf(0 < NameLen, WorkName, "Unknown: &H" & Hex(Value))
        CBFormatName = "Unknown: &H" & Hex(Value)
    End If
End Property

Sub DumpClipBoardFormatNames(Optional ByVal phWnd = 0&)
    If OpenClipboardRetry(phWnd) <= 0 Then Exit Sub
    Dim Ret: Ret = 0
    Do
        Ret = EnumClipboardFormats(Ret)
        If Ret = 0 Then Exit Do
        Debug.Print Ret, "&H" & Hex(Ret), CBFormatName(Ret)
    Loop
CLEANUP:
    Call CloseClipboard
End Sub

Function ClearClipBoard()
    If OpenClipboardRetry(0&) <= 0 Then ClearClipBoard = False: Exit Function
    Call EmptyClipboard
    ClearClipBoard = True
CLEANUP:
    Call CloseClipboard
    DoEvents
End Function

Function HasClipboardFormatsRetry(ByVal FormatNumberArray, Optional OrFlag = False, Optional MaxTryCount = 3)
    Dim Ret, TryCount
    For TryCount = 1 To MaxTryCount
        Ret = HasClipboardFormats(FormatNumberArray, OrFlag)
        If Not IsEmpty(Ret) Then: HasClipboardFormatsRetry = Ret: Exit Function
    Next
    HasClipboardFormatsRetry = False
End Function

Function HasClipboardFormats(ByVal FormatNumberArray, Optional OrFlag = False)
    If Not IsArray(FormatNumberArray) Then FormatNumberArray = Array(FormatNumberArray)
    If OpenClipboardRetry(0&) <= 0 Then HasClipboardFormats = Empty: Exit Function
    Dim FormatNumberDict: Set FormatNumberDict = CreateObject("Scripting.Dictionary")
    Dim Ret: Ret = 0
    Do
        Ret = EnumClipboardFormats(Ret)
        If Ret = 0 Then Exit Do
        FormatNumberDict(Ret) = True
    Loop
    For Each Ret In FormatNumberArray
        If FormatNumberDict.Exists(Ret) Then
            If OrFlag = True Then HasClipboardFormats = True: GoTo CLEANUP
        Else
            If Not OrFlag Then HasClipboardFormats = False: GoTo CLEANUP
        End If
    Next
    HasClipboardFormats = True
CLEANUP:
    Call CloseClipboard
    DoEvents
End Function

Function OpenClipboardRetry(Optional ByVal phWnd = 0&, Optional MaxTryCount = 5)
    Dim Ret, TryCount
    For TryCount = 1 To MaxTryCount
        Ret = OpenClipboard(phWnd)
        If 0 < Ret Then OpenClipboardRetry = Ret: Exit Function
        DoEvents
    Next
    OpenClipboardRetry = 0&
End Function

Mod_PizzaCutter.vba

Option Explicit

Const PizzaCutterSheetName = "ピザカッター" ' シート名と合わせる
Const PI = 3.14159265358979

Const DebugFlag = False
Const CompressPicture = True

#Const DuplicatePictureToMakePiece = True ' True: 元の画像を複製 ／ False: 1ピース毎に画像読み込み

Sub SelectImage()
    Call SelectImagefile
End Sub

Sub PizzaCutter()
    OriginalImage = OriginalImageFilename
    If OriginalImage Is Nothing Then Call MsgBox("画像を正しく指定してください", vbExclamation, PizzaCutterSheetName): Exit Sub
    If CutCount < 1 Or 360 < CutCount Then Call MsgBox("分割数を正しく指定してください", vbExclamation, PizzaCutterSheetName): Exit Sub
    Application.StatusBar = "分割中……"
    Application.ScreenUpdating = False
    CutPizza
    Application.ScreenUpdating = True
    Application.StatusBar = "分割完了！"
    Application.OnTime [NOW()+"00:00:05"], "ClearStatusBar"
End Sub

Private Function SelectImagefile()
    SelectImagefile = Application.GetOpenFilename(FileFilter:="元画像ファイル,*.bmp;*.jpg;*.jpeg;*.gif;*.png")
    If SelectImagefile = False Then Exit Function
    Application.EnableEvents = False
    OriginalImageFilenameCell.Value = SelectImagefile
    Application.EnableEvents = True
    OriginalImage = SelectImagefile
End Function

Private Sub CutPizza()
    Dim PizzaSheet
    With ThisWorkbook.Worksheets
        Set PizzaSheet = .Add(After:=.Item(.Count))
    End With
    Dim OrigWidth, OrigHeight, Radius, PieceAngle, DisperseDistance
    With OriginalImage
        OrigWidth = .Width
        OrigHeight = .Height
        Radius = WorksheetFunction.RoundUp(Sqr(OrigWidth ^ 2# + OrigHeight ^ 2#) / 2#, 0)
        PieceAngle = 360# / CutCount
        DisperseDistance = Radius * DisperseRate
    End With
    Dim AngleOff: AngleOff = AngleOffset - 90# ' 0時方向から始めるために補正
    Dim PieceNumber
    Dim WorkPiece, WorkRect, WorkGroup
    Dim BeginAngle, EndAngle
    Dim MinX, MinY, MaxX, MaxY
    Dim CvtToImageReq: CvtToImageReq = ConvertToImageRequest
    Dim PieceLeft, PieceTop
    Dim RangeInfo
    Dim TopLeftCell, ViewTopLeftCell
    Set WorkRect = PizzaSheet.Shapes.AddShape(msoShapeRectangle, Radius, Radius, 10, 10)
    Set TopLeftCell = WorkRect.TopLeftCell
    WorkRect.Delete
    Set WorkRect = PizzaSheet.Shapes.AddShape(msoShapeRectangle, Radius + Radius - OrigWidth / 2#, Radius + Radius - OrigHeight / 2#, 10, 10)
    Set ViewTopLeftCell = WorkRect.TopLeftCell
    WorkRect.Delete
    On Error Resume Next
    Set ViewTopLeftCell = ViewTopLeftCell.Offset(-3, -1)
    On Error GoTo 0
    Application.Goto ViewTopLeftCell, Scroll:=True
    TopLeftCell.Select
#If DuplicatePictureToMakePiece Then
    Dim WorkPieces: ReDim WorkPieces(1 To CutCount)
    Dim FirstPiece
    For PieceNumber = CutCount To 1 Step -1
        If PieceNumber = CutCount Then
            Set FirstPiece = DuplicatePicture(OriginalImage, PizzaSheet)
            With FirstPiece
                .AutoShapeType = msoShapePie
                .LockAspectRatio = False
                .Height = Radius * 2#
                .Width = Radius * 2#
            End With
            Set WorkPiece = FirstPiece
        Else
            Set WorkPiece = DuplicatePicture(FirstPiece)
        End If
        WorkPiece.Name = "WorkPiece" & PieceNumber ' ユニークな名前にしておかないと後にエラー発生
        Set WorkPieces(PieceNumber) = WorkPiece
    Next
#End If
    For PieceNumber = CutCount To 1 Step -1
        BeginAngle = PieceAngle * (PieceNumber - 1) + AngleOff
        EndAngle = PieceAngle * PieceNumber + AngleOff
        PieceLeft = TopLeftCell.Left + DisperseDistance * CosDegree((BeginAngle + EndAngle) / 2#)
        PieceTop = TopLeftCell.Top + DisperseDistance * SinDegree((BeginAngle + EndAngle) / 2#)
#If DuplicatePictureToMakePiece Then
        Set WorkPiece = WorkPieces(PieceNumber)
#Else
        Set WorkPiece = PizzaSheet.Shapes.AddShape(msoShapePie, PieceLeft, PieceTop, Radius * 2#, Radius * 2#)
#End If
        With WorkPiece
            .Left = PieceLeft: .Top = PieceTop
            .Line.Visible = msoFalse
            With .Adjustments
                .Item(1) = BeginAngle
                .Item(2) = EndAngle
            End With
#If DuplicatePictureToMakePiece Then
#Else
            With .Fill
                .Visible = msoTrue
                .UserPicture OriginalImageFilename
                .TextureTile = msoTrue
                .RotateWithObject = msoTrue
            End With
#End If
            With .PictureFormat
                With .Crop
                    .PictureWidth = OrigWidth
                    .PictureHeight = OrigHeight
                    With WorksheetFunction
                        Set RangeInfo = GetXYRangeInfo(BeginAngle, EndAngle, OrigWidth / (Radius * 2#), OrigHeight / (Radius * 2#))
                        MinX = RangeInfo("MinX"): MaxX = RangeInfo("MaxX")
                        MinY = RangeInfo("MinY"): MaxY = RangeInfo("MaxY")
                        MinX = Radius * .Min(0, MinX): MaxX = Radius * .Max(0, MaxX)
                        MinY = Radius * .Min(0, MinY): MaxY = Radius * .Max(0, MaxY)
                    End With
                    .PictureOffsetX = -(MaxX + MinX) / 2#
                    .PictureOffsetY = -(MaxY + MinY) / 2#
                End With
            End With
        End With
        
        If Not CvtToImageReq Then GoTo CONTINUE
        
        Set WorkRect = PizzaSheet.Shapes.AddShape(msoShapeRectangle, PieceLeft, PieceTop, Radius * 2#, Radius * 2#)
        With WorkRect
            .Line.Visible = msoFalse
            .Fill.Visible = msoFalse
        End With
        Set WorkGroup = PizzaSheet.Shapes.Range(Array(WorkPiece.Name, WorkRect.Name)).Group
        Set WorkPiece = ConvertToPicture(WorkGroup)
        With WorkPiece
            .Left = PieceLeft
            .Top = PieceTop
        End With
        Dim CropLeft, CropRight, CropTop, CropBottom
        With WorksheetFunction
            CropLeft = Radius * (1# + .Min(0, RangeInfo("AdjMinX")))
            CropRight = Radius * (1# - .Max(0, RangeInfo("AdjMaxX")))
            CropTop = Radius * (1# + .Min(0, RangeInfo("AdjMinY")))
            CropBottom = Radius * (1# - .Max(0, RangeInfo("AdjMaxY")))
        End With
        With WorkPiece.PictureFormat
            .CropLeft = CropLeft
            .CropRight = CropRight
            .CropTop = CropTop
            .CropBottom = CropBottom
        End With
        If CompressPicture Then
            ' .PictureFormat.Crop* の設定だけではデータとしては残ってしまっている
            ' →再度画像に変換して余白を切り取ったデータにする
            Set WorkPiece = ConvertToPicture(WorkPiece)
            With WorkPiece
                .Left = PieceLeft + CropLeft
                .Top = PieceTop + CropTop
            End With
        End If
CONTINUE:
        With WorkPiece
            .Name = "PizzaPiece" & PieceNumber
        End With
    Next
    PizzaSheet.Shapes("PizzaPiece1").Select
End Sub

Private Function DuplicatePicture(SourceShape, Optional TargetSheet)
    Const MaxShapeCopyCount = 10
    
    If IsMissing(TargetSheet) Then Set TargetSheet = SourceShape.Parent
    If SourceShape.Parent Is TargetSheet Then
        Set DuplicatePicture = SourceShape.Duplicate
        Exit Function
    End If
    
    Dim TryCount
    On Error Resume Next
    For TryCount = 1 To MaxShapeCopyCount
        If Not ClearClipBoard() Then
            If DebugFlag Then Debug.Print "* Notice * ClearClipBoard() failure"
            GoTo RETRY_COPY
        End If
        SourceShape.Copy
        If Err Then
            If DebugFlag Then Debug.Print "* Notice *", Err.Number, Err.Description
            GoTo RETRY_COPY
        End If
        If Not HasClipboardFormatsRetry(CF_BITMAP) Then
            If DebugFlag Then Debug.Print "* Notice * CF_BITMAP not found in ClipBoard"
            GoTo RETRY_COPY
        End If
        TargetSheet.Paste
        If Err Then
            If DebugFlag Then Debug.Print "* Notice *", Err.Number, Err.Description
            GoTo RETRY_COPY
        End If
        Exit For
RETRY_COPY:
        If DebugFlag Then Debug.Print "(*) ShapeCopyCount: " & TryCount & " => retry"
        Err.Clear
    Next
    On Error GoTo 0
    If MaxShapeCopyCount < TryCount Then Err.Raise 9999, Description:="Convert failure"
    Set DuplicatePicture = TargetSheet.Shapes(TargetSheet.Shapes.Count)
End Function

Private Function ConvertToPicture(SourceShape)
    Const MaxShapeCopyCount = 10
    
    Dim TryCount
    Dim TargetSheet: Set TargetSheet = SourceShape.Parent
    
    On Error Resume Next
    For TryCount = 1 To MaxShapeCopyCount
        If Not ClearClipBoard() Then
            If DebugFlag Then Debug.Print "* Notice * ClearClipBoard() failure"
            GoTo RETRY_COPY
        End If
        SourceShape.Copy
        If Err Then
            If DebugFlag Then Debug.Print "* Notice *", Err.Number, Err.Description
            ' 環境によっては .Copy でエラーが発生
            '   -2147221040   'Copy' メソッドは失敗しました: 'Shape' オブジェクト
            '   -2147221040   オートメーション エラーです。OpenClipboard に失敗しました
            GoTo RETRY_COPY
        End If
        If Not HasClipboardFormatsRetry(CF_BITMAP) Then
            If DebugFlag Then Debug.Print "* Notice * CF_BITMAP not found in ClipBoard"
            GoTo RETRY_COPY
        End If
        TargetSheet.PasteSpecial Format:="図 (PNG)", Link:=False, DisplayAsIcon:=False
        If Err Then
            If DebugFlag Then Debug.Print "* Notice *", Err.Number, Err.Description
            ' TODO: 環境によっては .PasteSpecial でエラーが頻発する
            '   1004         Worksheet クラスの PasteSpecial メソッドが失敗しました。
            '   1004         データを貼り付けできません。
            GoTo RETRY_COPY
        End If
        Exit For
RETRY_COPY:
        If DebugFlag Then Debug.Print "(*) ShapeCopyCount: " & TryCount & " => retry"
        Err.Clear
    Next
    On Error GoTo 0
    If MaxShapeCopyCount < TryCount Then Err.Raise 9999, Description:="Convert failure"
    Set ConvertToPicture = TargetSheet.Shapes(TargetSheet.Shapes.Count)
    SourceShape.Delete
End Function

Property Get PizzaCutterSheet()
    Set PizzaCutterSheet = ThisWorkbook.Worksheets(PizzaCutterSheetName)
End Property

Property Get OriginalImage()
    On Error Resume Next
    Set OriginalImage = PizzaCutterSheet.Shapes("OriginalImage")
    If Err Then Set OriginalImage = Nothing
End Property

Property Let OriginalImage(OriginalImageFilename)
    On Error Resume Next
    With PizzaCutterSheet
        .Shapes("OriginalImage").Delete
        If IsEmpty(OriginalImageFilename) Then Exit Property
        With .Pictures.Insert(OriginalImageFilename)
            .Name = "OriginalImage"
            Call .ShapeRange.ScaleHeight(1, msoFalse, msoScaleFromTopLeft)
            .Top = CanvasLeftTop.Top
            .Left = CanvasLeftTop.Left
        End With
    End With
End Property

Property Get OriginalImageFilenameCell()
    Set OriginalImageFilenameCell = PizzaCutterSheet.Range("OriginalImageFilename")
End Property

Property Get OriginalImageFilename()
    OriginalImageFilename = OriginalImageFilenameCell.Value
End Property

Property Get CanvasLeftTop()
    Set CanvasLeftTop = PizzaCutterSheet.Range("CanvasLeftTop")
End Property

Function CutCount()
    On Error Resume Next
    Dim Value: Value = Fix(PizzaCutterSheet.Range("CutCount").Value)
    If Err Then Value = 0
    CutCount = Value
End Function

Function AngleOffset()
    On Error Resume Next
    Dim Value: Value = CDbl(PizzaCutterSheet.Range("AngleOffset").Value)
    If Err Then Value = 0#
    AngleOffset = Value
End Function

Function DisperseRate()
    On Error Resume Next
    Dim Value: Value = CDbl(PizzaCutterSheet.Range("DisperseRate").Value)
    If Err Then Value = 0#
    DisperseRate = Value
End Function

Function ConvertToImageRequest()
    ConvertToImageRequest = PizzaCutterSheet.Range("ConvertToImage").Value
End Function

Function SinDegree(Degree)
    SinDegree = Sin(PI * Degree / 180#)
End Function

Function CosDegree(Degree)
    CosDegree = Cos(PI * Degree / 180#)
End Function

Function TanDegree(Degree)
    TanDegree = Tan(PI * Degree / 180#)
End Function

Function ArcTanDegree(Number)
    ArcTanDegree = Atn(Number) * 180# / PI
End Function

Function GetXYRangeInfo(ByVal BeginAngle, ByVal EndAngle, Optional ByVal RectRateX = 1#, Optional ByVal RectRateY = 1#)
    Dim Info: Set Info = New Collection
    Dim BeginX, BeginY, EndX, EndY, AdjBeginX, AdjBeginY, AdjEndX, AdjEndY
    Dim MinX, MaxX, MinY, MaxY, AdjMinX, AdjMaxX, AdjMinY, AdjMaxY
    With WorksheetFunction
        BeginAngle = NormDegree(BeginAngle)
        EndAngle = NormDegree(EndAngle)
        If EndAngle < BeginAngle Then BeginAngle = BeginAngle - 360#
        BeginX = CosDegree(BeginAngle): BeginY = SinDegree(BeginAngle)
        EndX = CosDegree(EndAngle): EndY = SinDegree(EndAngle)
        Call AdjustXY(BeginAngle, RectRateX, RectRateY, AdjBeginX, AdjBeginY)
        Call AdjustXY(EndAngle, RectRateX, RectRateY, AdjEndX, AdjEndY)
        If BeginAngle = EndAngle Then
            MaxX = 1#: AdjMaxX = RectRateX
            MinX = -1#: AdjMinX = -RectRateX
            MaxY = 1#: AdjMaxY = RectRateY
            MinY = -1#: AdjMinY = -RectRateY
        Else
            If BeginAngle <= 0# And 0# <= EndAngle Then
                MaxX = 1#: AdjMaxX = RectRateX
            Else
                MaxX = .Max(BeginX, EndX): AdjMaxX = .Max(AdjBeginX, AdjEndX)
            End If
            If BeginAngle <= 180# And 180# <= EndAngle Then
                MinX = -1#: AdjMinX = -RectRateX
            Else
                MinX = .Min(BeginX, EndX): AdjMinX = .Min(AdjBeginX, AdjEndX)
            End If
            If BeginAngle <= 90# And 90# <= EndAngle Then
                MaxY = 1#: AdjMaxY = RectRateY
            Else
                MaxY = .Max(BeginY, EndY): AdjMaxY = .Max(AdjBeginY, AdjEndY)
            End If
            If BeginAngle <= 270# And 270# <= EndAngle Then
                MinY = -1#: AdjMinY = -RectRateY
            Else
                MinY = .Min(BeginY, EndY): AdjMinY = .Min(AdjBeginY, AdjEndY)
            End If
        End If
    End With
    Info.Add BeginAngle, Key:="BeginAngle": Info.Add EndAngle, Key:="EndAngle"
    Info.Add BeginX, Key:="BeginX": Info.Add BeginY, Key:="BeginY"
    Info.Add EndX, Key:="EndX": Info.Add EndY, Key:="EndY"
    Info.Add AdjBeginX, Key:="AdjBeginX": Info.Add AdjBeginY, Key:="AdjBeginY"
    Info.Add AdjEndX, Key:="AdjEndX": Info.Add AdjEndY, Key:="AdjEndY"
    Info.Add MinX, Key:="MinX": Info.Add MaxX, Key:="MaxX"
    Info.Add MinY, Key:="MinY": Info.Add MaxY, Key:="MaxY"
    Info.Add AdjMinX, Key:="AdjMinX": Info.Add AdjMaxX, Key:="AdjMaxX"
    Info.Add AdjMinY, Key:="AdjMinY": Info.Add AdjMaxY, Key:="AdjMaxY"
    Set GetXYRangeInfo = Info
End Function

Private Sub AdjustXY(Angle, ByVal RectRateX, ByVal RectRateY, ByRef AdjX, ByRef AdjY)
    AdjX = CosDegree(Angle): AdjY = SinDegree(Angle)
    If RectRateX < Abs(AdjX) Then AdjX = RectRateX * Sgn(AdjX): AdjY = AdjX * TanDegree(Angle)
    If RectRateY < Abs(AdjY) Then AdjY = RectRateY * Sgn(AdjY): AdjX = AdjY / TanDegree(Angle)
End Sub

Private Function NormDegree(ByVal Degree)
    NormDegree = Degree - Fix(Degree / 360#) * 360#
    If NormDegree < 0# Then NormDegree = 360# + NormDegree
End Function

Private Sub ClearStatusBar()
    Application.StatusBar = False
End Sub

Sheet1.vba

Option Explicit

' シート名を「ピザカッター」にしてコードを貼り付け

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, OriginalImageFilenameCell) Is Nothing Then
        OriginalImage = OriginalImageFilename
    End If
End Sub