[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『図形の配置と回転』（REI）
お世話になります。
上手く書けるかわかりませんが、頑張ってみます。
あるイラストが1枚あります。このイラストはExcelマクロ有効ブックと同じフォルダー内にあります。このイラストを使って次のようなことは可能なのでしょうか。
・ユーザーにイラストの枚数を入力させる（2、4、6といったように偶数）
・入力された数字分、イラストを適当に配置する。（左を揃えたりせず、適当に）
・配置する範囲はA4用紙サイズ内
・配置されたイラストが、ランダムに回転している。（回転角度も適当に。もちろん回転しないものがあっても構いません）
よろしくお願いいたします。
＜ 使用 Excel：Office365、使用 OS：Windows10 ＞
可能は可能だろうが、前提が漠然とし過ぎています。 そして、ご自分ではどこまでトライされているのでしょうか？
質問を継続するなら、下記の点について明確にする必要があるでしょう。 ・イラストとは具体的にどんな種類のファイルか(拡張子) ・大きさは？ ・2、4、6個とのこと。配置の方針は？ ・回転した時、重なりは許容できるのか ・回転した時、A4に収まるセル範囲をはみ出すことは許容できるのか 等
イラストの数との関係もあるので、配置するところが難しい気がします。
回転のコードはマクロ記録を見ればすぐわかります。
たとえばこんな感じ。
Dim rot As Double
Dim shp As Shape
For Each shp In ActiveSheet.Shapes
rot = 360 * Rnd()
shp.IncrementRotation rot
Next
とりあえず私はここまで。
（γ） 2022/11/19(土) 15:34:01
ありがとうございます。申し訳ございません、私は初心者で一人で作ることができず、おたずねしている次第です。お許しください。
・イラストとは具体的にどんな種類のファイルか(拡張子) ・大きさは？
→イラストの表現が間違いでした。大変失礼しました。Excelの挿入で描ける図形です。大きさ的にはデフォルトのCellのサイズでいうと、B2:B3くらいの大きさです。
・2、4、6個とのこと。配置の方針は？
→図形は長方形で、配置の方針はありません。個数が多くなったときに、均等に散らばれば良いなと思っております。
・回転した時、重なりは許容できるのか
→重なりはなしです。
・回転した時、A4に収まるセル範囲をはみ出すことは許容できるのか 等
→印刷の関係で、はみ出すことはなしです。
この程度の補足説明で大丈夫でしょうか。
お時間ございますときに、ご教示いただけましたら幸いです。
（REI） 2022/11/19(土) 19:02:24
図形の配置はご自分で手でやってください。 手で簡単にできることですから、ご自分の好みで、好きなように配置してください。
回転する部分は、以下のマクロを使って下さい。 フォームのボタンをワークシートにおいて、それにマクロを登録するとよいでしょう。 ボタンを押すたびに、ランダムな角度で回転するはずです。
Sub test()
Dim rot As Double
Dim shp As Shape
For Each shp In ActiveSheet.Shapes
If shp.Type = msoAutoShape Then 'オートシェイプに限定
'A4縦に収まるセル範囲[A1:H39]の中の図形に限定
If Not Intersect(shp.TopLeftCell, [A1:H39]) Is Nothing Then
rot = 360 * Rnd()
shp.IncrementRotation rot 'Autoshapeをランダムに回転
End If
End If
Next
End Sub
私の発言はここまでとします。
（γ） 2022/11/19(土) 20:19:39
ありがとうございます。図形を手で配置して、それらをランダムに回転させることには成功しました。
図形の配置ですが、実は１枚だけではなく、配置や回転が異なるパタンで複数印刷をするため、マクロで動かしたいのです。
お時間のある方、ご教示いただけないでしょうか。本当に申し訳ございません。
（REI） 2022/11/20(日) 08:04:27
ご教示ありがとうございます。いまExcelで試していたのですが、γさん、スガリモノさんのおっしゃる通りかもしれません。多少図形サイズを小さくするとして、最大で20枚は配置したいので、収束しないといけませんね。20〜30枚程度の印刷ですので、印刷前にそれぞれのシートに手を加えて、なんとか対応をしてみます。
ありがとうございました。
（REI） 2022/11/20(日) 10:00:17
追記します。
回転だけでなく、既存の図形の位置をランダムに微修正するなら、
rot = 360 * Rnd()
shp.IncrementRotation rot 'Autoshapeをランダムに回転
shp.IncrementLeft 5 * (Rnd() - 0.5)
shp.IncrementTop 5 * (Rnd() - 0.5)
といった方法もあるでしょう。
そもそもの話、質問者さんの期待するランダム性が、 こちらでは想像ができないわけです。 最大20個であれば、余裕で配置はできるとは思います。 例えば、横4個、縦5個の格子状に20個を配置することはできますが、 たぶん、そうした規則的な配置ではなく、もっと不規則性のある自由な配置を想定しているのでしょう。
となると、位置そのものをランダムに設定していくことになりますが、 その際、追加するたびに、回転を加味した重なりチェックが必要になります。 もちろんやってできないことはないのでしょうけど、 そもそも何に使うものか、どんな重要なものかもわからないのに、 時間と労力を費やす気になれないのが正直なところです。
シートコピーして、ご自分の気のすむような配置に修正していただく、 という方針をとられるとのことで、現実的な対応と思いました。 （γ） 2022/11/20(日) 12:01:08
お時間ございます方、下記のコードの問題点を教えていただけますでしょうか。
オートシェイプはduplicateをつかって複数枚 ws1に貼り付けています。
With ws1
For i = 1 To .Shapes.Count
Set ShpR1 = .Range(.Shapes(i).TopLeftCell, .Shapes(i).BottomRightCell)
For j = i + 1 To .Shapes.Count
If i <> j Then
Set ShpR2 = .Range(.Shapes(j).TopLeftCell, .Shapes(j).BottomRightCell)
If Not Intersect(ShpR1, ShpR2) Is Nothing Then
.Shapes(j).IncrementLeft 300 * (Rnd() - 0.5)
.Shapes(j).IncrementTop 300 * (Rnd() - 0.5)
End If
End If
Next j
next i
（REI） 2022/11/21(月) 18:31:53
If Not Intersect(ShpR1, ShpR2) Is Nothing Then
これって、重なっていたら。。。あれこれ回転みたいな気が
するのですが？？；。え
ちがうのかな。。。＾＾；
自信が無くなってきました。(￣▽￣)
独自で作ったコードですと
4まいくらいでしたらスムーズに動きますが、20枚くらいになると
重ならない事が限りなくなくなってきて、無限ループ状態になりました。
m(__)m
（隠居Z） 2022/11/21(月) 19:13:46
お返事ありがとうございます。b4でも構いませんので、ご教示いただけますか。
（REI） 2022/11/21(月) 21:20:02
With ws1.Range("B2")
Set shp = ActiveSheet.Shapes.AddShape(Type:=msoShapeHeart, Left:=.Left, Top:=.Top, Width:=70, Height:=70)
End With
'図形の描画数をセット
On Error Resume Next
myNum = InputBox("10～20くらいの偶数を入れてください")
If myNum < 6 Or myNum > 20 Or myNum Mod 2 = 1 Then
MsgBox "10～20の偶数を入力してください"
ws1.Shapes.SelectAll
Selection.ShapeRange.Delete
Exit Sub
End If
'入力された分だけ描画
For k = 2 To myNum
ReDim shp2(myNum)
Set shp2(k) = shp.Duplicate
Next k
（REI） 2022/11/21(月) 21:25:21
シート名 Sheet1 が処理対象です。
停止は止まるまでESCを押し下げて下さいませ。
エラー処理は御座いません。
ご考察の際、何かの参考にでもなれば幸甚です。
お役に立たなければゴミ箱ポイお願いいたします。(*^^*)
きっと、もっとスマートな方法が有ると思います。でわ
m(_ _)m
Option Explicit
#If Win64 Then
Declare PtrSafe Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As Long) As Long
#Else
Declare Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As Long) As Long
#End If
Dim sp() As Object
Dim ws1 As Worksheet
Sub OneInstanceMain()
Dim iMax As Long
wsini
accept iMax
wsset iMax
shapemove iMax
Erase sp
End
End Sub
Private Sub wsini()
Dim i As Long
Dim oldSp As Variant
Set ws1 = Worksheets("Sheet1")
With ws1
.Cells.Clear
For Each oldSp In .Shapes
If oldSp.Type <> 8 Then
oldSp.Delete
End If
Next
End With
End Sub
Private Sub accept(ByRef x As Long)
Dim myNum As Variant
Dim inv_flg As Boolean
Do
myNum = Application.InputBox("4～20くらいの偶数を入れてください", "図の数入力", 16, , , , , 1)
If myNum = False Then
Erase sp
inv_flg = True
Exit Do
End If
If myNum < 4 Or myNum > 20 Or myNum Mod 2 = 1 Then
MsgBox "4～20の偶数を入力してください"
Else
x = myNum
Exit Do
End If
Loop
If inv_flg Then End
End Sub
Private Sub wsset(ByVal iMax As Long)
Dim i As Long
Dim r As Range
With ws1
Set r = .Range("B5")
ReDim sp(1 To iMax)
Set sp(1) = .Shapes.AddShape(Type:=msoShapeHeart, Left:=r.Left, Top:=r.Top, Width:=35, Height:=35)
For i = 2 To iMax
Set sp(i) = sp(1).Duplicate
Set r = r.Offset(1)
Next
End With
End Sub
Private Sub shapemove(ByVal iMax As Long)
Dim rr As Range
Dim rng() As Range
Dim r() As Range
Dim i As Long
Dim y As Long
Dim x As Long
Dim cnt As Long
Dim rNum As Long
ReDim rng(1 To iMax, 1 To 1)
ReDim r(1 To iMax)
With ws1
Set rr = .Range("B3:N29")
kensukeisan iMax, x
'* Roop Start A ************************************************************
Do
If GetAsyncKeyState(&H1B) Then Exit Do
cnt = cnt + 1
'* Roop Start B ************************************************************
Do
For i = 1 To iMax
rNum = Int((rr.Count - 1 + 1) * Rnd + 1)
Set rng(i, 1) = rr.Cells(rNum).Offset(-2).Resize(4, 1)
Set r(i) = rr.Cells(rNum)
Next
If kasanari_kakunin(rng, x) Then Exit Do
y = y + 1
If y Mod 32 = 0 Then
DoEvents
y = 0
End If
Loop
For i = 1 To iMax
With sp(i)
.Left = r(i).Left
.Top = r(i).Top
.Width = 35
.Height = 35
.IncrementRotation 360 * Rnd()
End With
Next
'Roop End A ***************************************************************
If cnt Mod 16 = 0 Then
DoEvents
cnt = 0
End If
Loop
'* Roop End B **************************************************************
End With
Erase rng, r
End Sub
Private Function kasanari_kakunin(ByRef v() As Range, ByVal x As Long) As Boolean
Dim i As Long
Dim k As Long
Dim j As Long
Dim a As Long
Dim tmp As Range
i = 1
Do
For k = i To UBound(v, 1) - 1
Set tmp = v(i, 1)
j = j + 1
If Intersect(tmp, v(k + 1, 1)) Is Nothing Then
a = a + 1
End If
Next
i = i + 1
If i Mod 8 = 0 Then DoEvents
If i >= UBound(v, 1) Then Exit Do
Loop
If a = x Then kasanari_kakunin = True
End Function
Private Sub kensukeisan(ByVal c As Long, ByRef x As Long)
Dim i As Long
Dim a As Long
For i = 1 To c - 1
a = a + i
Next
x = a
End Sub
（隠居Z） 2022/11/22(火) 10:22:56
お忙しいところ，このような大量のコードを作成くださり本当にありがとうございます。いま実行して希望の通り動いていることを確認いたしました。
一つだけお願いがございます。実行すると，ランダムに配置されている様子が示されますが，これを最終結果だけ（つまり実行ボタンを押して，重ならないことが確認できれば，一発で表示される）ようにしていただくことはできますでしょうか。
（REI） 2022/11/22(火) 10:52:10
追伸
１．サイズは独断で半分の35に設定。m(__)m
２．用紙サイズB4 配置 横置き 余白 狭いに収まるかと思います。
３．タイプが8のフォームコントロールのボタンを印刷範囲以外に設置して
マクロを実行すれば視認しやすいですよ。[初期化でボタンだけ消さない様に
しています。＾＾]
私のスキルでは。。。２．条件下では
シェイプ枚数 20
サイズ 50
Set rng(i, 1) = rr.Cells(rNum).Offset(-1).Resize(5, 2)
【うん？サイズが50以下なら、オフセットは要らないかも。ｗ】
くらいが、限界かも。。。きちんと、計算して、必要範囲を
算出する、ロジックを追加すれば良いのでせうが。何分、足し算と
引き算くらいしか理解致しておりませんので、目分量と10本の指数えて
やっていますのでご容赦を。数学に明るい方に笑われソぉですね。とほほ～。。。(◎_◎;)
きっと、更なる、アドバイスが有るかと思います。。。←多分。＾＾；
でわ
頑張ってくださいね。m(__)m
（隠居Z） 2022/11/22(火) 11:40:01
Private Sub shapemove(ByVal iMax As Long)
Dim rr As Range
Dim rng() As Range
Dim r() As Range
Dim i As Long
Dim y As Long
Dim x As Long
Dim cnt As Long
Dim rNum As Long
ReDim rng(1 To iMax, 1 To 1)
ReDim r(1 To iMax)
With ws1
Set rr = .Range("B4:N29")
kensukeisan iMax, x
'* Roop Start A ************************************************************
' Do
' If GetAsyncKeyState(&H1B) Then Exit Do
' cnt = cnt + 1
'* Roop Start B ************************************************************
Do
For i = 1 To iMax
rNum = Int((rr.Count - 1 + 1) * Rnd + 1)
Set rng(i, 1) = rr.Cells(rNum).Resize(5, 1)
Set r(i) = rr.Cells(rNum)
Next
If kasanari_kakunin(rng, x) Then Exit Do
y = y + 1
If y Mod 32 = 0 Then
DoEvents
y = 0
End If
Loop
For i = 1 To iMax
With sp(i)
.Left = r(i).Left
.Top = r(i).Top
.Width = 50
.Height = 50
.IncrementRotation 360 * Rnd()
End With
Next
'Roop End A ***************************************************************
' If cnt Mod 16 = 0 Then
' DoEvents
' cnt = 0
' End If
' Loop
'* Roop End B **************************************************************
End With
Erase rng, r
End Sub
最上部の宣言部
'#If Win64 Then ' Declare PtrSafe Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As Long) As Long '#Else ' Declare Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As Long) As Long '#End If
です。解りにくい説明で済みませんでした。
けど、あまり大きく変化しないみたいで
変更せずに、ボタンだけ設置して
押してはESCで止めて、を繰り返してお気に入りのパターンを
探した方が早いかもですね＾＾；
m(_ _)m
（隠居Z） 2022/11/22(火) 14:12:19
Dim rr As Range
Dim rng() As Range
Dim r() As Range
Dim i As Long
Dim y As Long
Dim x As Long
Dim cnt As Long
Dim rNum As Long
Randomize
ReDim rng(1 To iMax, 1 To 1)
Randomize
を入れて下さい。一回でも大きく、変化します。m(__)m
すみませ～～～ん。m(__)m
（隠居Z） 2022/11/22(火) 14:18:09
目的とかの説明がないので躊躇していましたが、 知らんぷりも大人げないので、トライしてみました。参考にしてください。 既に回答をいただいていますので、参考出品と言うことです。
・A4縦を想定（変更は可能。■部分のコードを修正のこと） ・シートは特定していませんので、アクティブなシートが処理対象となります。
【使用方法】 ・標準モジュールに全体をコピーし ・マクロmainをフォームコントロールのボタンに登録してください。
・mainを実行すると、作成枚数をInputBoxで求められます。 ・処理が完成すると、作成枚数を表示します。 ・乱数処理の結果、試行回数をオーバーすると、その旨メッセージが出るので、 mainを再実行してください。（図形は削除するので、そのまま再実行で可）
コードは少し怪しい前提を置いていますが、適当に修正してもらって結構です。
Option Explicit
Dim rng As Range 'A4の対象セル範囲 Dim numberOfShapes As Long '作成したい図形の数 Const maxCnt As Long = 10000 '図形作成の試行回数上限（仮置き）
Dim boundX1#, boundX2#, boundY1#, boundY2#
Sub main()
Dim sp As Shape
Dim cond As Boolean
Dim k&, j&
Dim boundaryTmp As Variant
Dim cnt As Long
Dim s As Variant
numberOfShapes = InputBox("作成する図形の数を入力(10～20程度）")
Application.ScreenUpdating = False
'Rnd -1 '乱数固定(debug用）
Randomize
'印刷範囲
Set rng = [A1:H39] '■■■■要修正
'オートシェイプを削除
For Each s In ActiveSheet.Shapes
If s.Type = msoAutoShape Then
s.Delete
End If
Next
'元になる図形
With Range("B2")
Set sp = ActiveSheet.Shapes.AddShape(Type:=msoShapeHeart, _
Left:=.Left, Top:=.Top, Width:=70, Height:=70)
End With
'回転してはみ出さない条件下での、図形中心の採り得る範囲を定める
Call SetRangeBoundary(sp, rng)
ReDim shp(1 To numberOfShapes) As Shape '図形
ReDim boundary(1 To numberOfShapes) As Variant 'その上限下限(x,y軸ごとに）
Set shp(1) = sp.Duplicate
Call setRandomPosition(shp(1)) 'ランダムに位置をセット
boundary(1) = getBoundary(shp(1)) '回転領域の外接正方形の位置(４点）
sp.Delete
k = 2
Do
Set shp(k) = shp(k - 1).Duplicate
line1:
cnt = cnt + 1 '処理回数カウント
If cnt > maxCnt Then MsgBox "回数オーバー": Exit Sub
Call setRandomPosition(shp(k)) 'ランダムに位置をセット
boundaryTmp = getBoundary(shp(k)) '回転領域の外接正方形の位置(４点）
For j = 1 To k - 1
'既存の図形と重なるかをチェック
'重なっていれば､冒頭に戻って、図形の位置を設定しなす
cond = isDuplicate(boundaryTmp, boundary(j))
If cond = True Then
GoTo line1
End If
Next
boundary(k) = boundaryTmp
k = k + 1
DoEvents
Loop Until k >= (numberOfShapes + 1)
Call rotate '各図形をランダムに回転
Application.ScreenUpdating = True
Debug.Print cnt
Dim shapesCount As Long
For Each s In ActiveSheet.Shapes
If s.Type = msoAutoShape Then
shapesCount = shapesCount + 1
End If
Next
MsgBox "図形の数 " & shapesCount
End Sub
Function SetRangeBoundary(sp As Shape, rng As Range)
Dim r#
' r = ((sp.Height) ^ 2 + sp.Width ^ 2) ^ 0.5
r = sp.Height * 1.2 'テキトーに狭くしてみた
With rng
boundX1 = .Left + r / 2
boundX2 = .Left + .Width - r / 2
boundY1 = .Top + r / 2
boundY2 = .Top + .Height - r / 2
End With
End Function
Function setRandomPosition(shp As Shape)
Dim x#, y#
x = boundX1 + Rnd() * (boundX2 - boundX1)
y = boundY1 + Rnd() * (boundY2 - boundY1)
shp.Left = x - shp.Width / 2
shp.Top = y - shp.Height / 2
End Function
Function getBoundary(sp As Shape) As Variant
Dim r#
Dim boundX1#, boundX2#, boundY1#, boundY2#
' r = ((sp.Height) ^ 2 + sp.Width ^ 2) ^ 0.5
r = sp.Height * 1.2 'テキトーなものに変更
With sp
boundX1 = .Left + .Width / 2 - r / 2
boundX2 = .Left + .Width / 2 + r / 2
boundY1 = .Top + .Height / 2 - r / 2
boundY2 = .Top + .Height / 2 + r / 2
End With
getBoundary = Array(boundX1, boundX2, boundY1, boundY2)
End Function
'二つの長方形が重なっているかのチェック（重なる→True)
Function isDuplicate(bound1 As Variant, bound2 As Variant) As Boolean
Dim x11#, x12#, y11#, y12#
Dim x21#, x22#, y21#, y22#
Dim checkX As Boolean
Dim checkY As Boolean
x11 = bound1(0): x12 = bound1(1): y11 = bound1(2): y12 = bound1(3)
x21 = bound2(0): x22 = bound2(1): y21 = bound2(2): y22 = bound2(3)
If x11 >= x21 And x22 >= x11 Then
checkX = True
ElseIf (x21 >= x11 And x12 >= x21) Then
checkX = True
End If
If y11 >= y21 And y22 >= y11 Then
checkY = True
ElseIf (y21 >= y11 And y12 >= y21) Then
checkY = True
End If
isDuplicate = checkX And checkY
End Function
Sub rotate()
Dim rot As Double
Dim shp As Shape
For Each shp In ActiveSheet.Shapes
If shp.Type = msoAutoShape Then 'オートシェイプに限定
If Not Intersect(shp.TopLeftCell, rng) Is Nothing Then
rot = 360 * Rnd()
shp.IncrementRotation rot 'ランダムに回転
End If
End If
Next
End Sub
【メモ】 ・もともと、重ならないという互いに関係のあるものを乱数で決めていくのは、 数が少なければいいですが、数が多くなると効率は悪くなります。 20でも1万回を超える試行になることも結構あります。 22くらいが限界かもしれません。 （別のアプローチとして、ある程度規則にしたがった配置を行ったうえで、 それぞれを多少ランダムに動かすという方式を取った方がよいものと思います。）
・試行回数限度を超えた場合、何段階か元に戻って再実行する方法もありますが、 失敗したら、最初からやり直すという方式です。
・回転を考えると、対角線を直径とする円になりますから、 本来はそれを考慮すべきかもしれません（図形が長方形そのものなどの場合）。 ハート形だと、実際の色付き部分は枠の長方形より狭くなるので、 本来のものより、少し小さい回転図形を考えても、実際は影響ないとみなして、 1.414倍を1.2倍くらいに節約しています。 ・乱数で作成しているので、逆に10個くらいのときは、配置に偏りがでます。 これに関する修正はするつもりはありません。 (11/23 procedureのスペルミスを修正しました） （γ） 2022/11/22(火) 15:13:13
なんとお礼を申し上げたらよいのかわかりません。お二人には長時間費やしてもらって本当に申し訳ございませんでした。私の考えをうまく反映してくださいました。本当にありがとうございました。またγさんには不快な思いをさせてしまい、申し訳ございませんでした。
ありがとうございました。
（REI） 2022/11/22(火) 16:57:30
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.