furyutei/0.README.md

## 0.README.md

      
  Raw
  

              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 OpenClipboard(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
    Call CloseClipboard
End Sub

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

Function HasClipboardFormats(ByVal FormatNumberArray, Optional OrFlag = False)
    If Not IsArray(FormatNumberArray) Then FormatNumberArray = Array(FormatNumberArray)
    If OpenClipboard(0&) <= 0 Then HasClipboardFormats = False: 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
End Function

## Mod_PizzaCutter.vba
Option Explicit

Const PizzaCutterSheetName = "ピザカッター" ' シート名と合わせる
Const PizzaLeftTopCellAddress = "G20" ' 切り分け後の画像の左上位置
Const PI = 3.14159265358979

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 LeftTopCell: Set LeftTopCell = PizzaSheet.Range(PizzaLeftTopCellAddress)
    Application.GoTo LeftTopCell.EntireRow.Cells(1), Scroll:=True
    LeftTopCell.Select
    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
    For PieceNumber = CutCount To 1 Step -1
        BeginAngle = PieceAngle * (PieceNumber - 1) + AngleOff
        EndAngle = PieceAngle * PieceNumber + AngleOff
        PieceLeft = LeftTopCell.Left + DisperseDistance * CosDegree((BeginAngle + EndAngle) / 2#)
        PieceTop = LeftTopCell.Top + DisperseDistance * SinDegree((BeginAngle + EndAngle) / 2#)
        Set WorkPiece = PizzaSheet.Shapes.AddShape(msoShapePie, PieceLeft, PieceTop, Radius * 2#, Radius * 2#)
        With WorkPiece
            .Line.Visible = msoFalse
            With .Adjustments
                .Item(1) = BeginAngle
                .Item(2) = EndAngle
            End With
            With .Fill
                .Visible = msoTrue
                .UserPicture OriginalImageFilename
                .TextureTile = msoTrue
                .RotateWithObject = msoTrue
            End With
            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 = ConvertToPictureByCopyAndPaste(WorkGroup)
        With WorkPiece
            .Left = PieceLeft
            .Top = PieceTop
            .Line.Visible = msoFalse
        End With
        With WorkPiece.PictureFormat
            .CropLeft = Radius * (1# + WorksheetFunction.Min(0, RangeInfo("AdjMinX")))
            .CropRight = Radius * (1# - WorksheetFunction.Max(0, RangeInfo("AdjMaxX")))
            .CropTop = Radius * (1# + WorksheetFunction.Min(0, RangeInfo("AdjMinY")))
            .CropBottom = Radius * (1# - WorksheetFunction.Max(0, RangeInfo("AdjMaxY")))
        End With
CONTINUE:
        With WorkPiece
            .Name = "PizzaPiece" & PieceNumber
        End With
    Next
    PizzaSheet.Shapes("PizzaPiece1").Select
End Sub

Private Function ConvertToPictureByCopyAndPaste(SourceShape)
'    Const MaxClearClipBoardCount = 5 ' 保留: OpenClipBoard に失敗するときは5回繰り返しても失敗する場合あり
    Const MaxShapeCopyCount = 10
    Const MaxWaitClipBoardReadyCount = 3

    Dim TryCount

'    For TryCount = 1 To MaxClearClipBoardCount
'        If ClearClipBoard Then Exit For
'        Debug.Print "(*) ClearClipBoardCount: " & TryCount & " => retry"
'        DoEvents
'    Next
'    If MaxClearClipBoardCount < TryCount Then Err.Raise 8888, Description:="ClearClipBoard failure"

    On Error Resume Next
    For TryCount = 1 To MaxShapeCopyCount
        ClearClipBoard ' とりあえず失敗しても気にしない
        DoEvents
        SourceShape.Copy
        If Err Then
            Debug.Print "* Notice *", Err.Number, Err.Description
            ' 環境によっては .Copy でエラーが発生
            '   -2147221040   'Copy' メソッドは失敗しました: 'Shape' オブジェクト
            '   -2147221040   オートメーション エラーです。OpenClipboard に失敗しました
            GoTo RETRY_COPY
        End If
        Dim CheckCount
        For CheckCount = 1 To MaxWaitClipBoardReadyCount
            DoEvents
            If HasClipboardFormats(CF_BITMAP) Then Exit For
            Debug.Print "(*) WaitClipBoardReadyCount: " & CheckCount & " => retry"
        Next
        If MaxWaitClipBoardReadyCount < CheckCount Then
            Debug.Print "* Notice * CF_BITMAP not found in ClipBoard"
            GoTo RETRY_COPY
        End If
        SourceShape.Parent.PasteSpecial Format:="図 (PNG)", Link:=False, DisplayAsIcon:=False
        If Err Then
            Debug.Print "* Notice *", Err.Number, Err.Description
            ' TODO: 環境によっては .PasteSpecial でエラーが頻発する
            '   1004         Worksheet クラスの PasteSpecial メソッドが失敗しました。
            '   1004         データを貼り付けできません。
            GoTo RETRY_COPY
        End If
        DoEvents
        Exit For
RETRY_COPY:
        Debug.Print "(*) ShapeCopyCount: " & TryCount & " => retry"
        Err.Clear
    Next
        DoEvents
    On Error GoTo 0
    If MaxShapeCopyCount < TryCount Then Err.Raise 9999, Description:="Convert failure"
    Set ConvertToPictureByCopyAndPaste = Selection.ShapeRange
    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
	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 OpenClipboard(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
	Call CloseClipboard
	End Sub

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

	Function HasClipboardFormats(ByVal FormatNumberArray, Optional OrFlag = False)
	If Not IsArray(FormatNumberArray) Then FormatNumberArray = Array(FormatNumberArray)
	If OpenClipboard(0&) <= 0 Then HasClipboardFormats = False: 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
	End Function
	Option Explicit

	Const PizzaCutterSheetName = "ピザカッター" ' シート名と合わせる
	Const PizzaLeftTopCellAddress = "G20" ' 切り分け後の画像の左上位置
	Const PI = 3.14159265358979

	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 LeftTopCell: Set LeftTopCell = PizzaSheet.Range(PizzaLeftTopCellAddress)
	Application.GoTo LeftTopCell.EntireRow.Cells(1), Scroll:=True
	LeftTopCell.Select
	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
	For PieceNumber = CutCount To 1 Step -1
	BeginAngle = PieceAngle * (PieceNumber - 1) + AngleOff
	EndAngle = PieceAngle * PieceNumber + AngleOff
	PieceLeft = LeftTopCell.Left + DisperseDistance * CosDegree((BeginAngle + EndAngle) / 2#)
	PieceTop = LeftTopCell.Top + DisperseDistance * SinDegree((BeginAngle + EndAngle) / 2#)
	Set WorkPiece = PizzaSheet.Shapes.AddShape(msoShapePie, PieceLeft, PieceTop, Radius * 2#, Radius * 2#)
	With WorkPiece
	.Line.Visible = msoFalse
	With .Adjustments
	.Item(1) = BeginAngle
	.Item(2) = EndAngle
	End With
	With .Fill
	.Visible = msoTrue
	.UserPicture OriginalImageFilename
	.TextureTile = msoTrue
	.RotateWithObject = msoTrue
	End With
	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 = ConvertToPictureByCopyAndPaste(WorkGroup)
	With WorkPiece
	.Left = PieceLeft
	.Top = PieceTop
	.Line.Visible = msoFalse
	End With
	With WorkPiece.PictureFormat
	.CropLeft = Radius * (1# + WorksheetFunction.Min(0, RangeInfo("AdjMinX")))
	.CropRight = Radius * (1# - WorksheetFunction.Max(0, RangeInfo("AdjMaxX")))
	.CropTop = Radius * (1# + WorksheetFunction.Min(0, RangeInfo("AdjMinY")))
	.CropBottom = Radius * (1# - WorksheetFunction.Max(0, RangeInfo("AdjMaxY")))
	End With
	CONTINUE:
	With WorkPiece
	.Name = "PizzaPiece" & PieceNumber
	End With
	Next
	PizzaSheet.Shapes("PizzaPiece1").Select
	End Sub

	Private Function ConvertToPictureByCopyAndPaste(SourceShape)
	' Const MaxClearClipBoardCount = 5 ' 保留: OpenClipBoard に失敗するときは5回繰り返しても失敗する場合あり
	Const MaxShapeCopyCount = 10
	Const MaxWaitClipBoardReadyCount = 3

	Dim TryCount

	' For TryCount = 1 To MaxClearClipBoardCount
	' If ClearClipBoard Then Exit For
	' Debug.Print "(*) ClearClipBoardCount: " & TryCount & " => retry"
	' DoEvents
	' Next
	' If MaxClearClipBoardCount < TryCount Then Err.Raise 8888, Description:="ClearClipBoard failure"

	On Error Resume Next
	For TryCount = 1 To MaxShapeCopyCount
	ClearClipBoard ' とりあえず失敗しても気にしない
	DoEvents
	SourceShape.Copy
	If Err Then
	Debug.Print "* Notice *", Err.Number, Err.Description
	' 環境によっては .Copy でエラーが発生
	' -2147221040 'Copy' メソッドは失敗しました: 'Shape' オブジェクト
	' -2147221040 オートメーションエラーです。OpenClipboard に失敗しました
	GoTo RETRY_COPY
	End If
	Dim CheckCount
	For CheckCount = 1 To MaxWaitClipBoardReadyCount
	DoEvents
	If HasClipboardFormats(CF_BITMAP) Then Exit For
	Debug.Print "(*) WaitClipBoardReadyCount: " & CheckCount & " => retry"
	Next
	If MaxWaitClipBoardReadyCount < CheckCount Then
	Debug.Print "* Notice * CF_BITMAP not found in ClipBoard"
	GoTo RETRY_COPY
	End If
	SourceShape.Parent.PasteSpecial Format:="図 (PNG)", Link:=False, DisplayAsIcon:=False
	If Err Then
	Debug.Print "* Notice *", Err.Number, Err.Description
	' TODO: 環境によっては .PasteSpecial でエラーが頻発する
	' 1004 Worksheet クラスの PasteSpecial メソッドが失敗しました。
	' 1004 データを貼り付けできません。
	GoTo RETRY_COPY
	End If
	DoEvents
	Exit For
	RETRY_COPY:
	Debug.Print "(*) ShapeCopyCount: " & TryCount & " => retry"
	Err.Clear
	Next
	DoEvents
	On Error GoTo 0
	If MaxShapeCopyCount < TryCount Then Err.Raise 9999, Description:="Convert failure"
	Set ConvertToPictureByCopyAndPaste = Selection.ShapeRange
	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
	Option Explicit

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

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