Skip to content

Instantly share code, notes, and snippets.

@furyutei
Last active May 13, 2022 04:53
Show Gist options
  • Save furyutei/fc7df34880fd549c6b9ff12c030fb535 to your computer and use it in GitHub Desktop.
Save furyutei/fc7df34880fd549c6b9ff12c030fb535 to your computer and use it in GitHub Desktop.
[Excel][VBA]エクセルでピザカッター(画像を等しい角度で分割)

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

PowerPointで、丸い画像を強引に等分する方法というツイートを見て、エクセルでもやってみたくなったので
ピザの分割
こちらにはソースコードのみさらしてあります。マクロ有効ワークシートを共有してありますので、ダウンロードしてお試し下さい。
エクセルでは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
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
Option Explicit
' シート名を「ピザカッター」にしてコードを貼り付け
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, OriginalImageFilenameCell) Is Nothing Then
OriginalImage = OriginalImageFilename
End If
End Sub
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment