オートシェイプの線の単純結合(2)

とりあえず，難しいことは考えずに，複数の図形でもいっぺんにくっつけるように書き直してみました。

結合前の線を描くときに，一定の方向性で描いた場合にのみ使える状態です。

ノードの順番は距離云々でも判断がつかないため，そのへんは仕方ないと考えるしかない気がしています。

しくみをわかって使えば十分いける気はしています。とりあえず自分用としてはここまでかな。

Sub test()

    Dim SShapeRange As ShapeRange: Set SShapeRange = ActiveWindow.Selection.ShapeRange
    Dim TSld As Slide: Set TSld = SShapeRange(1).Parent
    
    Dim SShape() As Shape: ReDim SShape(1 To SShapeRange.Count)
    Dim i As Long, j As Long
    For i = 1 To SShapeRange.Count
        Set SShape(i) = ActiveWindow.Selection.ShapeRange(i)
    Next
    
    Dim NodeCollection As New Collection
    Dim str As String, NodeStr As String
    
    For i = 1 To SShapeRange.Count
        NodeStr = StrFreeform(SShape(i))
        For j = 1 To UBound(Split(NodeStr, vbTab))
            If i <> 1 And j = 1 Then
                str = str & vbTab & Left(Split(NodeStr, vbTab)(j), Len(Split(NodeStr, vbTab)(j)) - 1) & "0"
            Else
                str = str & vbTab & Split(NodeStr, vbTab)(j)
            End If
        Next
    Next
    
    DrawFreeForm str, TSld

End Sub

Function StrFreeform(図形 As Shape) As String
    Dim 各ノード As ShapeNode
    For Each 各ノード In 図形.Nodes
        StrFreeform = StrFreeform & vbTab & CLng(各ノード.Points(1, 1)) & "," & CLng(各ノード.Points(1, 2)) & "," & 各ノード.SegmentType
    Next
End Function

Sub DrawFreeForm(strNode As String, pSlide As Slide)
    Dim i As Long, j As Long, ff As FreeformBuilder, sf As Shape
    Dim NodeValue() As Variant
    ReDim NodeValue(UBound(Split(strNode, vbTab)), 3)
    
    For i = 0 To UBound(Split(strNode, vbTab))
        For j = 0 To UBound(Split(Split(strNode, vbTab)(i), ","))
            NodeValue(i, j) = Split(Split(strNode, vbTab)(i), ",")(j)
        Next
    Next

    Set ff = pSlide.Shapes.BuildFreeform(msoEditingAuto, CLng(NodeValue(1, 0)), CLng(NodeValue(1, 1)))
    For i = 2 To UBound(Split(strNode, vbTab))
        If CLng(NodeValue(i, 2)) = msoSegmentCurve And i <= UBound(Split(strNode, vbTab)) - 2 Then
            ff.AddNodes msoSegmentCurve, msoEditingCorner, NodeValue(i, 0), NodeValue(i, 1), NodeValue(i + 1, 0), NodeValue(i + 1, 1), NodeValue(i + 2, 0), NodeValue(i + 2, 1)
            i = i + 2
        Else
            ff.AddNodes msoSegmentLine, msoEditingAuto, NodeValue(i, 0), NodeValue(i, 1)
        End If
    Next
    Set sf = ff.ConvertToShape
End Sub

実行後下の図形ができます。

以上。

オートシェイプの線の単純結合

本当に久しぶりにパワーポイントのvbaネタです。

せっかく整理できたので，一つくらい書こうと思い，完全に忘れていたのでトライアンドエラーの末，うまく調整したらよくなりそうなものを載せてみます。

どなたかばっちりなものに作り上げてくれるのもありがたい。。

さて，パワーポイント等でお絵かきをよくするんですが，ドロー系のように，線の結合をしたいことがあります。

確かにパワーポイントには図形の結合なるものがあるんですが，

この状態で図形の結合をすると

(;´▽｀A``

そうじゃないんですよ

とても残念なことになります。

そこで，以前ベジェ曲線のことをやったなぁと思い，あれをうまく使えばいけるかな・・と　かなり適当にやっつけてみました。

使い方に気を付けないと想定通りいきませんが，気を付ければ使えるレベルになったので公開。

Sub test()
Dim TSld As Slide: Set TSld = ActiveWindow.Selection.ShapeRange(1).Parent
Dim Shape1 As Shape, Shape2 As Shape
Set Shape1 = ActiveWindow.Selection.ShapeRange(1)
Set Shape2 = ActiveWindow.Selection.ShapeRange(2)

Dim Col1 As New Collection, col2 As New Collection

Dim i As Long
For i = 1 To UBound(Split(StrFreeform(Shape1), vbTab))
    Col1.Add Split(StrFreeform(Shape1), vbTab)(i)
Next
For i = 1 To UBound(Split(StrFreeform(Shape2), vbTab))
    col2.Add Split(StrFreeform(Shape2), vbTab)(i)
Next


Dim col3 As New Collection
For i = 1 To Col1.Count
    col3.Add Col1(i)
Next

For i = 1 To col2.Count
    If i = 1 Then
        col3.Add Left(col2(i), Len(col2(i)) - 1) & "0"
    Else
        col3.Add col2(i)
    End If
Next

Dim str As String
For i = 1 To col3.Count
    str = str & vbTab & col3(i)
Next


DrawFreeForm str, TSld

End Sub

Function StrFreeform(図形 As Shape) As String
    Dim 各ノード As ShapeNode
    For Each 各ノード In 図形.Nodes
        StrFreeform = StrFreeform & vbTab & CLng(各ノード.Points(1, 1)) & "," & CLng(各ノード.Points(1, 2)) & "," & 各ノード.SegmentType
    Next
End Function

Sub DrawFreeForm(strNode As String, pSlide As Slide)
    Dim i As Long, j As Long, ff As FreeformBuilder, sf As Shape
    Dim NodeValue() As Variant
    ReDim NodeValue(UBound(Split(strNode, vbTab)), 3)
    
    For i = 0 To UBound(Split(strNode, vbTab))
        For j = 0 To UBound(Split(Split(strNode, vbTab)(i), ","))
            NodeValue(i, j) = Split(Split(strNode, vbTab)(i), ",")(j)
        Next
    Next

    Set ff = pSlide.Shapes.BuildFreeform(msoEditingAuto, CLng(NodeValue(1, 0)), CLng(NodeValue(1, 1)))
    For i = 2 To UBound(Split(strNode, vbTab))
        If CLng(NodeValue(i, 2)) = msoSegmentCurve And i <= UBound(Split(strNode, vbTab)) - 2 Then
            ff.AddNodes msoSegmentCurve, msoEditingCorner, NodeValue(i, 0), NodeValue(i, 1), NodeValue(i + 1, 0), NodeValue(i + 1, 1), NodeValue(i + 2, 0), NodeValue(i + 2, 1)
            i = i + 2
        Else
            ff.AddNodes msoSegmentLine, msoEditingAuto, NodeValue(i, 0), NodeValue(i, 1)
        End If
    Next
    Set sf = ff.ConvertToShape
End Sub

この位置関係だと，左の図形を先に選んで，shiftやらctrlキーを押しながらもう一つの図形を選んでください。選ぶ順番が影響します。

そしてtestマクロ を実行すると，

何が起こったかよくわかりませんね，ずらしてみると

ちゃんとノードを結合していきます。

選ぶ順番気を付けてくださいね。そこうまくつくれていません。

これが実用段階までいけば，何回かに分けて書いたオートシェイプのラインをきれいにつなげていけるものが出来上がるはず。

・・・

作る暇はないなぁ。。(;´▽｀A``でも便利なものにはなりそうなんですけどね・・

公開後もうすこし試しましたが・・・まだまだ問題はけっこうありますね。

ノードの各順番によって想定通りうまくくっつかない。

でも，しくみがわかってれば図形を選ぶ順番である程度予測は付くかんじ。　二つとも中央から書いたらうまくいきませんが，一定の方向性をもってそれぞれの図形を書いていけばつかえるかなぁ。

今のところは自分用ですねぇ・・

( ´Д｀)=3

職場で備忘録として，自分のここをよく見るんですが，

ドメイン変えたりしたときの弊害で所々リンクが切れてました。

昨日とっても困ったので，今日重い腰を上げて全部記事をチェックしてみて，リンク切れをなくしたつもり。。

なかなか偏った中身になってて，自分がよくやるようなことをやっぱり書いてるなぁとしみじみ。

Wordのテーブルの制御とかコンテンツコントロールのこととか，あんまり他で見ないですもんね。。

かたよってるなぁ・・

備忘録としての役割はかなり回復。

EXCEL VBA ふりがな関連のマクロ

余裕がないけど仕事中に意外に簡単に組めて，便利だなぁと思ったのでメモ

まったくパワポで遊べてない名前詐欺ですがここでもとりあえず(;´▽｀A``

上の状態から下の状態にするマクロです。　氏名もふりがなも　全角スペースで姓と名を区切るというルールにしています。
半角スペースにも対応できるようにできそうですが，今は面倒なのでここまで。ちゃんと引数あったので修正

コードはこちら

Sub ふりがな設定(氏名セル As Range, ふりがな As String)
    With 氏名セル
        .Characters(1, InStr(1, 氏名セル.Value, "　", vbTextCompare) - 1).PhoneticCharacters = _
            Left(ふりがな, InStr(1, ふりがな, "　", vbTextCompare) - 1)
        .Characters(InStr(1, 氏名セル.Value, "　", vbTextCompare) + 1).PhoneticCharacters = _
            Mid(ふりがな, InStr(1, ふりがな, "　", vbTextCompare) + 1)
        With .Phonetic
            .CharacterType = xlHiragana
            .Font.Name = "MS UI Gothic"
            .Font.Size = 9
            .Alignment = xlPhoneticAlignCenter
        End With
        .Phonetics.Visible = True
    End With
End Sub

Sub Test()
    ふりがな設定 Selection, Selection.Offset(, 1).Value
End Sub

ふりがなをセルの文字列全体に対してつけると，あまりかっこよくないことがあるので，姓と名にわけてつけるようにしました，というだけのマクロ。

考えてみればきわめて簡単なものでしたが，急ぐときにぱぱっと書けるとは限りませんので，

備忘録でした。

再帰呼び出しが気になってます

自分めも 再帰呼び出しがいま気になって仕方ないです

フラクタル図形とかをパワーポイントでvba

使って書けたら背景とかにも使えるかなあ

まだ興味が沸いた段階

Excelの本は過去に出ているようですが、中古でものすごい高そうでした。自分で組み立てていくしかないかなー

メモ終わり

配列再び。

Excelシートを配列を用いてデータ処理をする時期をすごしています。

一時ワークシートを作っていろいろするより早さもそうですが，コードもシンプルになっていい。

ただ，一時ワークシートの利点と思っているのが，セルの番地等が一目瞭然である点です。

一時ワークシートを作成し，データ処理をしているところでコードを止めてあげると情報を一望でき，メンテナンスは比較的簡単。

配列は・・・ローカルウィンドウでちくちく見てますが，データ構造がずれたりするとほんと大変ですよね。。

本職でコーディングするわけではないので，仕様はころころ変わりますし，その仕事の大前提がひっくり変えることも多々ありますから，そういう時にこまったことになります。

やはり同じ流れでクラスモジュールに気持ちが向かっていくんだなぁと，苦笑しつつ去年のコードを見返しています。

thomさんからいろいろアドバイスをいただいて，去年は大量のデータを扱うことをしていました。

今年は去年ほどの項目数がないので，配列でちゃちゃっとすませてしまったんですが，それでも６０程度の項目はあるのかな，メンテナンスのことを考えると，ちょっと途方にくれます。

自分なら自分のメンテナンスは癖がわかってますからやりやすいですが，他人のコードはどこになにがあるのかがわからないと困ります。

特に配列ですから数値指定のものが多く，とても困る。

リハビリ兼ねてすこしずつクラスモジュールを思い出すことにしました。

標準モジュール

Option Explicit

Function GetDataAsArray() As Variant
    GetDataAsArray = Sheets(1).Range("a1").CurrentRegion.value
End Function

Function GetDataAsCollection() As Collection
    Dim arr: arr = GetDataAsArray
    Dim C As Collection: Set C = New Collection
    Dim i, j
    
    For i = LBound(arr, 1) + 1 To UBound(arr, 1)
        
        With New Person
            If C.Count = 0 Then .AdjustArrSize UBound(arr, 2)
            For j = 1 To UBound(arr, 2)
                .LetParameter j, arr(i, j)
            Next
            C.Add .Self
        End With
    Next
    Set GetDataAsCollection = C
End Function

Sub テスト()
    Dim a As Collection: Set a = GetDataAsCollection
    Stop
End Sub

クラスモジュール　クラス名 Person

Option Explicit
Private Parameter() As Variant

Property Get 名前() As String
    名前 = Parameter(1)
End Property

Property Get Self() As Object
    Set Self = Me
End Property

Sub LetParameter(paramNo, value)
    If Not Not Parameter Then Else Call AdjustArrSize(100)
    Parameter(paramNo) = value
End Sub

Function GetParameter(paramNo) As Variant
    GetParameter = Parameter(paramNo)
End Function

Sub AdjustArrSize(No As Long)
    ReDim Preserve Parameter(1 To No)
End Sub

昨年度教えてもらったやり方から，現時点ではほぼ変わっていません。
ただ，当時項目数が増えたときにその上限を書き換えにいく必要があり，それがちょっと面倒だなぁと思っていました。
大きめに項目数を見て作ればいい話ですが，Emptyが並んでいると，あまり広くないローカルウィンドウがとても狭く感じるのでデータ項目数に合わせて可変にしたいと思っていました。

その部分をとりあえず付け足して書いてみた。

AdjustArrSizeというのを付け足してRedimしているだけですけどね・・(;´▽｀A``

ただし，忘れる前提で話をしているので，それを忘れて実行したときは100項目というかなり大きめの項目数で動きはするように作ってみた。

If Not Not Parameter Then Else Call AdjustArrSize(100)

Not Not　ってのがわかっていませんが，いろいろネットを見てたら出てきたので Redimし忘れ対策です。

結果は

とりあえず私が望むデータの項目数に応じた構成データ数というのは実現できているようです。スマートな書き方ではないとは思いますが，見た目はとりあえず成った。

そしてクラスモジュールならプロパティ実装部分に重要な項目を集めておけばコードがだいぶ見やすくなると思います。

とても大事な部分ですが，

With New Person
If C.Count = 0 Then .AdjustArrSize UBound(arr, 2)
For j = 1 To UBound(arr, 2)
.LetParameter j, arr(i, j)
Next
C.Add .Self
End With

この部分がどうも理解できていません。

やってることはわかるけどどうしてこう書けるんだ??

記録マクロとかでもよくWithでさくっと書かれているときに戸惑うことはあります。苦手な部分なんでしょうね。

いろいろ試して物にしていこう。

Worksheetのコピー

前回書いてみた通り，

Sub a() 'だめ
    Dim PWB As Workbook: Set PWB = Workbooks.Add()
    Dim PWS As Worksheets: Set PWS = ThisWorkbook.Worksheets(1).Copy(after:=PWB.Worksheets(PWB.Worksheets.Count))
End Sub

Sub b() 'うまくいく
    Dim PWB As Workbook: Set PWB = Workbooks.Add()
    Dim PWS As Worksheet:  ThisWorkbook.Worksheets(1).Copy after:=PWB.Worksheets(PWB.Worksheets.Count)
    Set PWS = ActiveSheet
End Sub

PWSという変数に，シートのコピーを一気に入れたい。
たった一行の差なんですが，コピー直後は必ずコピーしたばかりのシートがアクティブになってるからという前提で書くbの書き方が嫌いです。

オブジェクトブラウザでみても
Sub Copy([Before], [After])
Excel.Worksheets のメンバー

と書いてあるから，ワークシートを返すのかなぁと思うので直接入れれそうに感じるんですがだめなようです。

何が悪いのかなぁ　( ´ー｀)ﾌｩｰ．．．

・・・
ここまで書いてて，もう一回オブジェクトブラウザ見て思った。

Addは
Function Add([Before], [After], [Count], [Type]) As Object
Excel.Worksheets のメンバー

Copyは
Sub Copy([Before], [After])
Excel.Worksheets のメンバー

Functionじゃないから返さないよね・・・(ノД`)・゜・。

書き方の問題じゃないなぁ( ´ー｀)