選択されている図形の種類を判定して図形のサイズと位置を再調整するボタンの中身のメモ

 

エクセルアドインの午後のパレットの午後の

見出し付きテキストボックスは複数の図形をグループ化しているだけ

 

 

レイアウトの崩れてしまったのを右の状態にするボタン

再調整画像付きTB

選択された図形を再調整する

これの動きのメモ

 

サイズの調整をしてから位置の調整をしている

サイズ調整は

見出しと本文の図形の幅を画像に合わせる

高さは文字に合わせる

 

位置の調整は

基準が見出し図形にして

画像図形を見出しの下側

本文を画像図形の下側

 

これには選択された図形が何の図形なのかを取得する必要がある

見出し図形なのか、本文用のテキストボックスなのかとか

これが難しかったのでメモしておこうかと

もっといい方法がありそうだけど思いつかない

 

 

 

グループ化された図形の選択状態は2種類ある

AとBと区別すると

これはグループ化図形をそのまま選択した状態で

名前のところが「グループ化 339」になっている

これがA

 

これはグループ化図形の中の見出し部分の図形を選択した状態

名前のところが「正方形/長方形 340」になっている

これがB

 

グループ化図形の中の画像図形を選択した状態

名前のところが「図 342」になっている

これもB

 

グループ化図形そのもの全体を選択している状態Aと

グループ化図形の中の1つの図形を選択しているBの違い

B状態は特殊で1つのグループ化図形を選択している時だけで

複数のグループ化図形を選択している状態では発生しない

 

こういう状況はありえない

複数図形を選択しているのにグループ化図形の中の1つの図形を選択した状態

左がB状態で右がA状態って言うことになはらない

 

必ずこうなる

A状態の選択が2つになる

図形のいろいろな選択状態(Selection.ShapeRangeの中)を見てみる

---

Sub testShape()

    Dim SR As ShapeRange

    Set SR = Selection.ShapeRange

    

End Sub

---

図形を選択した状態で↑を実行して一時停止して

SRの中身を見てみる

 

ローカルウィンドウの表示方法

メニューの表示からローカル ウィンドウで表示される

 

 

一個の四角形図形を選択した状態

グループ化図形ではないのでグループ化に関係するところの値は

GroupItemsがこのメンバにアクセスできるの～

ParentGroupが指定された値は境界を超えて～

とかまともな値が入っていないのがわかる

TypeがmsoAutoShape

 

 

グループ化図形を選択した状態

GroupItemsは+が付いているのでなにか値が入っている

ParentGroupはさっきと同じでエラーみたいになっている

TypeはmsoGroupになっている、この図形はグループ化図形ですってことかな

GroupItemsの中身を見てみる

Item1から3があってそれがが個別の図形を表しているみたい

Item1の中身を見てみる

Item1の型はVariant/Object/Shapeって表示されているから

図形

3つは見出しと本文と画像の3つの図形ってことみたい

 

 

グループ化図形の中の本文用図形のテキストボックスを選択した状態

GroupItemsはエラーみたいになっている

TypeはTextBoxになっている

ParentGroupはなにか値が入っているので中身を見てみる

Typeの値がmsoGroupだからグループ化図形

Nameもグループ化 339ってなっている

 

ここまでまとめると

簡単に見分けることができるのはグループ化図形そのままの時で

これはType＝msoGroupで判定できる

問題は単独図形なのかグループ化図形の中の1つなのかの判断

ParentGroupになにか値が入っているなら

グループ化図形の中の1つってことになるけど

この判定の仕方がわからない

例えば

Sub testShape()

    Dim SR As ShapeRange

    Set SR = Selection.ShapeRange

        

    If IsError(SR.ParentGroup) Then ’エラーの判定

        '処理

    End If

    

    If SR.ParentGroup Is Nothing Then ’空っぽの判定

        '処理

    End If    

End Sub

エラーの判定と空っぽの判定どちらもエラーになる

指定された値は境界を超えていますはエラーでも空っぽでもないってことみたい

そうなんだろうけど、でもどうやって判定すればいいかわからないので

エラーになるならエラーになったら単独図形で

エラーにならなかったらグループ化図形の中の1つ

って判定することにした

 

 

 

 

複数の図形が選択されている場合

GroupItems、ParentGroupともに値なし

TypeはmsoShapeTypeMixedってのになっているなあ、これは気にしてない

複数の図形が選択されている場合の特徴は

Countが2以上の数値になっているのと

その数値分のItemがあること

なのでSelection.ShapeRange.Countが2以上なら

複数の図形が選択されているって判定できる

 

あとはそれぞれの図形の種類の判定

単独図形なら見出しの図形ってことになるからそれ以外の

見出し付きテキストボックスと画像付き見出し付きテキストボックス

この2つの中の図形をそれぞれ判定することになる

2つのグループ化図形を選択した状態これをそれぞれ取得して

中を見てみる

Sub testShape()

    Dim SR As ShapeRange

    Set SR = Selection.ShapeRange

    Dim GP1 As GroupShapes, GP2 As GroupShapes

    Set GP1 = SR.Item(1).GroupItems

    Set GP2 = SR.Item(2).GroupItems

End Sub

GroupShapesっていうクラス？型？を使って

ShapeRange.Item(n).GroupItemsでそれぞれのグループ化図形を取得している

少し広げてみると

1個目のGroupItemsの中にはItemが2つ

2個めのGroupItemsの中にはItemが3つ

あるのがわかる

GP1のItem1のTypeはmsoAutoShape

Item2のTypeはmsoTextBox

 

これで何の図形かわかるけど

実際にGP1.Item(1).Typeの値を取得するとmsoAutoShapeじゃなくて

数値の1になってる、これだとわかりにくいので

DrawingObjectっていうのを使ってこれをTypeNameにまかせてみたら

わかりやすくRectangleっていう文字列が返ってきた

テキストボックスも17っていう数字じゃなくて文字列のTextBox

このDrawingObjectってのが便利だけどよくわからなくて

候補一覧には出てこない、なんで？

 

画像図形はPictureで返ってくる、わかりやすい

 

これで図形の取得や判別はできたので後は順番にサイズと位置を変更するだけ

 

デザイン画面

再調整画像付きTBボタンの名前はCommandButton7

名前をつけるのがめんどくさくなってそのままの名前になっている

このボタンのクリックイベントに

 

Private Sub CommandButton7_Click()

    Call ReAjustAllShape選択図形すべての位置とサイズを再調整    

End Sub

'ボタンのクリックイベントにくっつける
Sub ReAjustAllShape選択図形すべての位置とサイズを再調整()
'選択された図形を取得、グループ化された図形の場合は分解して配列に入れた状態で取得
'配列の順番は0＝見出し、1=本文(テキストボックス)、2=画像
    On Error Resume Next
    
    Dim SR As ShapeRange
    Dim SS() As Shape
    Set SR = Selection.ShapeRange
    
    If SR.Count = 1 Then
    '選択図形が一個の場合(完全単独か1つのグループ化の中の一つの図形を選択した状態)
        SS = GetShapes特殊選択状態(SR.Item(1))
        '処理
        Call ReAjust図形タイプごとに位置とサイズを再調整(SS)
        
        
    Else
    '複数図形が選択されている場合
        Dim i As Long
        For i = 1 To SR.Count
            
            If SR.Item(i).Type = msoGroup Then
            'グループ化された図形の場合
                SS = GetShapesグループ化図形の中の図形を配列で取得(SR.Item(i).GroupItems)
            Else
            '単独図形の場合
                ReDim SS(0)
                Set SS(0) = SR.Item(i)
            End If
            
            '処理
            Call ReAjust図形タイプごとに位置とサイズを再調整(SS)
            
        Next
    End If
End Sub

フォームモジュールに書いても同じだけど

このへんから標準モジュールに書いているんだなあ

書いてあるのは選択された画像を順番に取得して

図形のサイズと位置を再調整するプロシージャに投げている( ´∀｀)つ ミ

フローチャートだとエクセル方眼紙大活躍！

見なおしたら間違っているのに気づいた

選択画像が1個の時の処理を辿るとNext i に行っているけどそのまま終了が正解

フローチャートで条件分岐の図形は＜＞◇菱型みたいなんだけど

文字表示にやたら面積を取るので使いにくいから全部四角形で作った

使いにくく感じるのは書き方が良くない？

---

Function GetShapes特殊選択状態(CS As Shape) As Shape()
    Dim SS() As Shape
    Dim GP As GroupShapes
    '渡されたshapeがグループ化図形か単独図形なのかを判断するのに
    'エラーを使っている
    'GroupShapesの変数に入れようとしてエラーになれば単独図形と判断して
    'エラーが起きたらmyErrに飛ぶ
        
    If CS.Type <> msoGroup Then
        On Error GoTo myErr
    'ParentGroupがあるグループ化の中のどれか1つの図形選択状態
        Set GP = CS.ParentGroup.GroupItems
    ElseIf CS.Type = msoGroup Then
    '1つのグループ化された図形選択状態
        Set GP = CS.GroupItems
    Else
    
myErr:
    'ParentGroupがない単独図形
        ReDim SS(0)
        Set SS(0) = CS
    End If
        
        
    If Not GP Is Nothing Then
    'グループ化された図形の場合、順番を揃えて配列に入れる
        SS = GetShapesグループ化図形の中の図形を配列で取得(GP)
    End If
    
            
    Err.Clear
    GetShapes特殊選択状態 = SS
    
End Function

 

 

 

これは選択された図形がグループ化図形なのか

グループ化図形の中の1つの図形なのか

単独図形なのかの判定

方法を思いつかないのでエラーで判定しているところ

 

 

 

 

---

Function GetShapesグループ化図形の中の図形を配列で取得(GP As GroupShapes) As Shape()
'グループ化された図形の中の図形を並べなおして図形の配列にして返す
    Dim SS() As Shape
    Dim i As Long
    '図形の数取得
    ReDim SS(GP.Count - 1) '.GroupItems.Count - 1)
        
    'GroupshapeのItemそれぞれのDrawingObjectのTypeNameを調べてどの図形化の判別
    'Shapes配列の
    '0＝見出し、1=本文、2=画像を入れる
    For i = 1 To UBound(SS) + 1 ' GP.GroupItems.Count
    
        With GP
        Select Case TypeName(.Item(i).DrawingObject)
            Case "TextBox"
                Set SS(1) = .Item(i) '.GroupItems(i) '本文図形、テキストボックス
            Case "Picture"
                Set SS(2) = .Item(i) ' .GroupItems(i) '画像図形
            Case Else
                Set SS(0) = .Item(i) ' .GroupItems(i) '見出し図形
        End Select
        End With
    Next i
    GetShapesグループ化図形の中の図形を配列で取得 = SS
End Function

 

 

グループ化図形のGroupShapesを送って中の図形を種類判定して

0＝見出し、1=本文、2=画像の順番に配列に入れて返している

 

 

 

---

Sub ReAjust図形タイプごとに位置とサイズを再調整(SS() As Shape, Optional FitTBHeight As Boolean = False)
'FitTBHeight=Trueでテキストボックスの高さをセルのグリッドに合わせる
'SS(0)が見出しの図形、SS(1)がテキストボックス,SS(2)が画像図形のはず
'それぞれの図形のの位置とサイズを再調整
    Dim Mida As Shape, TB As Shape, Pic As Shape
        
    Select Case UBound(SS)
        Case 0
        '見出しだけの時
            '処理、特にやること無い？
        Case 1
        '見出しとテキストボックスのとき
            Call ReadjustSub位置合わせ(SS(0), SS(1))
            If FitTBHeight Then
                Call FitHeightToCell図形の高さをセルグリッドに合わせる(SS(1))
            End If
        Case 2
        '見出しとテキストボックスと画像のとき
            Call Adjust見出しとテキストボックスと画像の位置調整(SS(0), SS(1), SS(2))
            
            If FitTBHeight Then
                Call FitHeightToCell図形の高さをセルグリッドに合わせる(SS(1))
            End If
    End Select
    
End Sub

 

さっき並べ直した図形の配列を受けて、図形のサイズと位置を再調整する

プロシージャに投げている

図形の数が1なら見出しだけ、2こなら見出し付きテキストボックス

3個なら画像付き見出し付きテキストボックス

って判定している

'myShape As Shape 見出し図形
'myTB As Shape     テキストボックス
'fitCell As Boolean    Trueなら図形の左上を近くのセルの左上に合わせる
'fitHeight As Boolean  Trueならテキストボックスの下の位置をセルグリッドに合わせる
Public Sub ReadjustSub位置合わせ(myShape As Shape, myTB As Shape, _
                                Optional fitCell As Boolean = False, _
                                Optional fitHeight As Boolean = False)
    Dim myTop As Single
    '見出し用の図形をセルに合わせてから本文のテキストボックスを見出しにあわせる
    If fitCell Then
        Call FitShapes2Cell図形位置を最寄りのセルにピッタリ(myShape)
    End If
    
    myTop = myShape.Top
    myShape.TextFrame2.AutoSize = msoAutoSizeShapeToFitText
    myShape.Top = myTop
    With myTB
        .Width = myShape.Width
        .TextFrame2.AutoSize = msoAutoSizeShapeToFitText
        .TextFrame2.VerticalAnchor = msoAnchorTop
        .Top = myShape.Top + myShape.Height
        .Left = myShape.Left
        
        'テキストボックスの高さの再調整してセルに合わせる
        If fitHeight Then
            Dim cellH As Single, TBH As Single
            cellH = .BottomRightCell.Top + .BottomRightCell.Height
            TBH = .Top + .Height
            .TextFrame2.VerticalAnchor = msoAnchorMiddle '縦位置中央
            .Height = .Height + (cellH - TBH)
        End If
    End With
End Sub

 

見出し付きテキストボックスのサイズと位置を再調整

 

 

 

'Mida As Shape    見出し用図形
'TB As Shape   テキストボックス
'Pic As Shape  画像図形
Sub Adjust見出しとテキストボックスと画像の位置調整(Mida As Shape, TB As Shape, Pic As Shape)
'渡されたテキストボックスと見出しと画像の位置を再調整
   
    With Mida
        .Width = Pic.Width
        .TextFrame2.AutoSize = msoAutoSizeShapeToFitText
        Pic.Left = .Left
        If .Fill.Transparency = 0 Then
        '見出しの背景色が完全不透明なら
            Pic.Top = .Top + .Height
        Else
            Pic.Top = .Top
        End If
    End With
    
    With Pic
        TB.Width = .Width
        TB.Top = .Top + .Height
        TB.Left = .Left
        TB.TextFrame2.AutoSize = msoAutoSizeShapeToFitText
    End With
    
End Sub

 

画像付き見出し付きテキストボックスのサイズと位置を再調整

 

Sub FitHeightToCell図形の高さをセルグリッドに合わせる(S As Shape)
'渡された図形の高さをセルグリッドに合わせる
'テキストの縦の表示位置は中央に変更
    Dim cellH As Single
    Dim SH As Single
    With S
        cellH = .BottomRightCell.Top + .BottomRightCell.Height
        SH = .Top + .Height
        .TextFrame2.VerticalAnchor = msoAnchorMiddle 'テキストの縦位置中央
        .Height = .Height + (cellH - SH)
        
    End With
   
End Sub

 

テキストボックスの下の枠をセルグリッドに合わせる

---

 

これでサイズと位置を再調整ボタンに関係するのは全部かな

やっぱりフローチャートあったほうがわかりやすいかなあ

フローチャート追記した

 

 

 

 

2019/10/23追記

以下の日記はヤフーブログのときのものではてなブログとは関係ない

ヤフーブログも後日対応してもらって解決したので取り消し
主な原因はタブ文字が空白4文字になっていて、これで見かけより多くの文字数が消費されていたから

追記ここまで

 

今回の記事も文字が多いので全部書いてから投稿ボタンを押してエラーになって

書き直しが怖くて少し書いては投稿→記事の修正→少し書いては投稿をして書いた

これを繰り返している間は公開範囲設定を公開しないにして

書き終わったら全公開にして投稿

これなら変なエラーで記事を作りなおすことは避けられるけどめんどくさいｗ

ここまでで文字数は9500文字くらい

昨日はこれくらいでも投稿エラーになった