Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(指定なし : 指定なし)
2つ以上のシェイプを隙間無しで縦方向並べるマクロ
投稿日時: 20/11/16 17:21:31
投稿者: rodeo540
メールを送信

標記のマクロを作成しています。
オートシェイプに回転が無い場合はいいのですが、
回転がある場合、回転後のオートシェイプのHeight,Width等の取得に困っています。
Rotationからsin、cos等にHeight,Widthを乗じて取得しようとしていますが、
なかなかうまくいきません。
 
マクロというよりは幾何学の問題かもしれませんが、
どなたか妙案ご存じないでしょうか?
回転は任意の度数、オートシェイプの四角だけでなく、
三角、五角形、直線等任意のものをイメージしています。
 
ちなみに一応エクセルで投稿していますが、
ワード上のVBAで作成しています。
(大きな違いは無いと思いますが。。。)

回答
投稿日時: 20/11/16 18:15:28
投稿者: simple

> 回転がある場合、回転後のオートシェイプのHeight,Width等の取得に困っています。
> Rotationからsin、cos等にHeight,Widthを乗じて取得しようとしていますが、

それでよいと思いますよ。
ご自分でトライしたものを提示してください。勿論完成品でなくてよいのです。

回答
投稿日時: 20/11/16 20:57:10
投稿者: simple

>2つ以上のシェイプを隙間無しで縦方向並べる
ということの意味を勘違いしていたかもしれませんねえ。
 
こんなことですか?

Sub test()
    Dim theta#      '# は As Double と同じ(型宣言文字)
    Dim l#, t#, w#, h#
    Dim v#
    
    l = 145#
    t = 130#
    w = 120#
    h = 65#
    
    theta = 30#
    v = h / Cos(theta * Application.Pi() / 180#)
    
    With ActiveSheet.Shapes.AddShape(msoShapeRectangle, l, t, w, h)
        .IncrementRotation (360# - theta)
    End With
    With ActiveSheet.Shapes.AddShape(msoShapeRectangle, l, t + v, w, h)
        .IncrementRotation (360# - theta)
    End With
    With ActiveSheet.Shapes.AddShape(msoShapeRectangle, l, t + 2 * v, w, h)
        .IncrementRotation (360# - theta)
    End With
End Sub

投稿日時: 20/11/16 23:23:36
投稿者: rodeo540
メールを送信

お返事ありがとうございます。
今日明日と時間が取れませんので、
明後日に再度投稿致します。
取り急ぎ、お礼まで。

投稿日時: 20/11/18 17:21:09
投稿者: rodeo540
メールを送信

お聞きしたかった内容は、既に色々と挿入されているオートシェイプを
整列させるイメージです。
 
「上下に(等間隔で)整列」、「左揃え」、「右揃え」等の機能がデフォルトであるかと思いますが、
類似の機能として、「上下に(隙間なく)整列」の動作になります。
 
ワードVBAで恐縮ですが、作成中は以下の内容です。
 
------------------------------------------------------------
Option Base 1
Sub 図_整列_縦_隙間無()
 
Dim shp As Shape
Dim Location() As Variant
 
On Error Resume Next
 
'配列数を再定義(ソートの関係で必要)
cnt = 0
For Each shp In Selection.ShapeRange
 cnt = cnt + 1
Next
ReDim Location(cnt, 6)
 
'選択オートシェイプの位置を取得
cnt = 0
For Each shp In Selection.ShapeRange
 cnt = cnt + 1
 shp.RelativeVerticalPosition = wdRelativeVerticalPositionPage
 shp.RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
 Location(cnt, 1) = cnt
 Location(cnt, 2) = shp.Top
 Location(cnt, 3) = shp.Height
 Location(cnt, 4) = shp.Width
 '図形中心点から左上頂点までの長さ
 Location(cnt, 5) = ((shp.Height) ^ 2 + (shp.Width) ^ 2) ^ 0.5
  
 Location(cnt, 3) = shp.Height / 2 - shp.Height * Cos((shp.Rotation) / 45 * Atn(1))
 Location(cnt, 4) = shp.Height * Cos((shp.Rotation) / 45 * Atn(1))
 Location(cnt, 5) = shp.Width * Sin((shp.Rotation) / 45 * Atn(1))
 Location(cnt, 6) = shp.Rotation
Next
 
'上方に位置する順にソート
Call バブルソート(Location, 2)
 
'上方から配置
For T = 1 To cnt
 If T = 1 Then
  Atop = Location(T, 2)
  Selection.ShapeRange(Location(T, 1)).Top = Atop
  
 Else ←ここから下を悩んでます。2つ目以降を配置する場合
  Atop = Atop + Location(T - 1, 3) + Location(T - 1, 4) + Location(T - 1, 5)
' If Selection.ShapeRange(Location(T, 1)).Rotation <> 0 Then
' Selection.ShapeRange(Location(T, 1)).Top = Atop + Location(T, 4)
' Else
    Selection.ShapeRange(Location(T, 1)).Top = Atop
' End If
 End If
   
  '上のオートシェイプと自身のオートシェイプ回転無し
' If Selection.ShapeRange(Location(T, 1)).Rotation = 0 And Selection.ShapeRange(Location(T - 1, 1)).Rotation = 0 Then
 
  '上のオートシェイプ回転有、自身のオートシェイプ回転無し
' ElseIf Selection.ShapeRange(Location(T, 1)).Rotation = 0 And Selection.ShapeRange(Location(T - 1, 1)).Rotation <> 0 Then
' Selection.ShapeRange(Location(T, 1)).Top = Atop + (Location(T - 1, 4) / 2) * Sin((Location(T - 1, 5) / 45 * Atn(1)))
  '上のオートシェイプ回転無し、自身のオートシェイプ回転有り
' ElseIf Selection.ShapeRange(Location(T, 1)).Rotation <> 0 And Selection.ShapeRange(Location(T - 1, 1)).Rotation = 0 Then
' Selection.ShapeRange(Location(T, 1)).Top = Atop + (Location(T, 4) / 2) * Sin((Location(T, 5) / 45 * Atn(1)))
' '上のオートシェイプと自身のオートシェイプ回転有り
' ElseIf Selection.ShapeRange(Location(T, 1)).Rotation <> 0 And Selection.ShapeRange(Location(T - 1, 1)).Rotation = 0 Then
' Selection.ShapeRange(Location(T, 1)).Top = Atop + (Location(T, 4) / 2) * Sin((Location(T, 5) / 45 * Atn(1))) + (Location(T - 1, 4) / 2) * Sin((Location(T - 1, 5) / 45 * Atn(1)))
' End If
   
Next
 
'横位置を設定
Selection.ShapeRange.Align msoAlignCenters, msoFalse
 
End Sub
Sub バブルソート(ByRef Location() As Variant, ByVal keyPos As Long)
 
Dim vSwap
Dim i As Integer
Dim j As Integer
Dim k As Integer
     
For i = LBound(Location, 1) To UBound(Location, 1)
 For j = LBound(Location) To UBound(Location) - 1
  If Location(j, keyPos) > Location(j + 1, keyPos) Then
   For k = LBound(Location, 2) To UBound(Location, 2)
    vSwap = Location(j, k)
    Location(j, k) = Location(j + 1, k)
    Location(j + 1, k) = vSwap
   Next
  End If
 Next j
Next i
 
End Sub

回答
投稿日時: 20/11/18 19:43:51
投稿者: simple

されようとしていることが理解できません。
もう少し明確にしていただくと、皆さんからもコメントがあるんじゃないでしょうか。
 
>シェイプを隙間無しで縦方向並べる
とのことですが、
(1)図形には、Left,Top,Width,Heightで定まる枠のようなものがありますよね。
   隙間無く並べるというのは、その枠をということですか?
   その中に入っている、実際の図形(例:五角形)との関係は?
   五角形の各辺を意識して、詰めて並べるということですか?
 
(2)仮に、その枠を並べることだと考えた場合でも、
   回転角が異なっていれば(例、30度と60度)、
   必ず交差してしまうので、回転角を保持したまま、「隙間無く並べる」って
   殆ど意味を成さないように思います。
   そのあたりの整理もお願いします。

投稿日時: 20/11/18 19:58:07
投稿者: rodeo540
メールを送信

文字だけですとうまく表現が出来なくてすみません。
 
矢印とひし形、四角、丸等をフローを作成して縦に並べたときに
連続的に縦方向の隙間なく配置したいイメージです。
 
>(1)図形には、Left,Top,Width,Heightで定まる枠のようなものがありますよね。
> 隙間無く並べるというのは、その枠をということですか?
> その中に入っている、実際の図形(例:五角形)との関係は?
> 五角形の各辺を意識して、詰めて並べるということですか?
>(2)仮に、その枠を並べることだと考えた場合でも、
> 回転角が異なっていれば(例、30度と60度)、
> 必ず交差してしまうので、回転角を保持したまま、「隙間無く並べる」って
> 殆ど意味を成さないように思います。
> そのあたりの整理もお願いします。
 
確かに、四角形を回転させた45度回転させた
ひし形ぐらいしか下の図形とは繋がらないですね。
枠をくっつけたとしても、枠の中の図形は繋がらないですし。
 
回転していないものを対象とした内容に留めておきます。
ご指摘ありがとうございました。