|
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 |