Wordつづき(2)

あいかわらずWordで悪戦苦闘しています。ほんっとわかりません(;´▽｀A``

でもまだあきらめません。使いこなせればとてもいいものとわかっている以上もうすこし食い下がる。。

さて，個人情報を含まない形で作成中のファイルをもってきたので，それで試してみました。

shapeのduplicateメソッドは使うこととしました。
ページ指定をparagraphsであつかうのはばかげているので，そのへんを必死にさがしていたら

Word VBA 簡易リファレンス及び使用例(VB6.0) - VBレスキュー(花ちゃん)

こちらでいい情報が書いてありました。 GoToメソッドはrangeオブジェクトを返すらしいじゃないですか。
なのでたとえば２ページ目を指定したい場合は

ドキュメントオブジェクト.GoTo(wdGoToPage,wdGoToAbsolute,2)

と書ける。そしてrangeオブジェクトってことはそのままPasteつけれるじゃないか(/・ω・)/

無知なわたしとしては，この情報は歓喜に値するもの。まさにこれがほしかった。

ページ内ではleftやtopプロパティ，または絶対位置を指定するそれに類するものでなんとでもなる。

ページ移動で苦闘していたので，光が見えた気がします。

それでやりなおしたのがこのコード
今回はExcelからの流し込み部分に興味ないのでそのへんは除かれまたはコメントアウトしています。
必要なページ数はマクロでやるんじゃなく，マクロ実行する前にctrl+enterで先に確保しておく想定です。

Sub 名簿作り()
    Application.ScreenUpdating = False
    'Dim EX As Excel.Application, WB As Excel.Workbook, DataArray As Variant
    'Set EX = New Excel.Application
    'Set WB = Workbooks(ThisDocument.Path & "\H30名簿データ.xlsx")
    Dim NewDoc As Document: Set NewDoc = Documents.Add(Template:=ThisDocument.FullName)
    
    Dim Shp(1 To 9) As Shape, TableName As Variant, i As Long
    TableName = Array("dummy", "1組", "2組", "3組", "4組", "5組", "6組", "7組", "8組", "9組")
    
    Set Shp(1) = NewDoc.Shapes("元")
    Shp(1).Name = TableName(1)
    
    For i = 2 To 9
        Set Shp(i) = Shp(1).Duplicate
        Shp(i).Name = TableName(i)
    Next
    
    For i = 1 To 5
        Shp(i).Left = 180 * (i - 1)
    Next
    For i = 6 To 9
        Shp(i).Select: Selection.Cut
        NewDoc.GoTo(wdGoToPage, wdGoToAbsolute, 2).Paste
        Shp(i).Left = 180 * (i - 6)
    Next

End Sub

表はこんな感じです。１つだけ準備して"元"という名前を付けています。
５５行４列　一つ調整するだけでもWordはけっこう反乱を起こしますがこれが９クラス分となるとどれだけWordがいらいらする相手になるか想像できるもの(;´▽｀A``

マクロ実行前

マクロ実行後

データ流し込んだりは，個人情報の関係で職場でしかできません。テストデータを用意するのはめんどくさい(;´▽｀A``あとは切り取り線も用意したりするかなぁ。

とにかく，それっぽく動き出した。。

捕足
Wordは画面更新させながらマクロを動かすと，かなり表示に力を注いでいるのでScreenUpdatingはFalseにしました。

Array関数で名前のリストを作っていますが，ダミーを0番目にいれることで１スタートできるよう調整するようになりました。

まずDuplicateメソッドで増やした後，移動させるというように整理しました。

２ページ目に移す奴はカット&ペーストで処理するようにしました。

だいぶ　いやなところは減りました。

引き続き取り組んでいこう。

WordVBA つづき

前回の続きです。Wordの１ページ内での制御は簡単ですが，複数のページにまたがる場合は大変面倒でした。

今のところはまだ限定的ですが，練習を繰り返して力をつけていきたいものです。

どんな文書でもいいので，　"元"という名前の図形をつくって，下記のコードを試します。後で使うために Excelで　"データ"というブックを開いている前提での話となります。
Excelとの連携の方法にもいろいろあるんですが，わたしの職場のように自動暗号化される環境ではWorkbooks.Open等が使えない場合がありますので，そういうときの場合のためにすでにWordとExcelで
使う文書を開いた状態で使う，という状況を想定

Sub test()

Dim EXApp As Excel.Application, WB As Excel.Workbook
Set EXApp = GetObject(, "Excel.Application")
Set WB = EXApp.Workbooks("データ.xlsx")

Dim NewDoc As Document
Set NewDoc = Documents.Add(Template:=ThisDocument.FullName)

Dim Shp(1 To 6) As Shape, NameArray As Variant
NameArray = Array("いち", "に", "さん", "よん", "ご", "ろく")

NewDoc.Shapes("元").Select: Selection.Copy
NewDoc.Characters.Last.InsertBreak wdPageBreak
NewDoc.Paragraphs(1).Range.Paste
NewDoc.Paragraphs(2).Range.Paste


Set Shp(1) = NewDoc.Paragraphs(1).Range.ShapeRange(1)
Shp(1).Name = "Shp1"
Dim i As Long
For i = 2 To 3
    Shp(1).Select: Selection.Copy
    NewDoc.Paragraphs(1).Range.Paste
    Set Shp(i) = NewDoc.Paragraphs(1).Range.ShapeRange(i)
    Shp(i).Name = "Shp" & i
    Shp(i).Left = Shp(i - 1).Left + 200
Next

Set Shp(4) = NewDoc.Paragraphs(2).Range.ShapeRange(1)
Shp(4).Name = "Shp4"
NewDoc.Paragraphs(2).Range.Select
For i = 5 To 6
    Shp(4).Select: Selection.Copy
    NewDoc.Paragraphs(2).Range.Paste
    Set Shp(i) = NewDoc.Paragraphs(2).Range.ShapeRange(i - 3)
    Shp(i).Name = "Shp" & i
    Shp(i).Left = Shp(i - 1).Left + 200
Next


End Sub

もっとスマートに書きたいものですが，Duplicateでやると，パラグラフ(2)での処理に失敗してしまいましたので，嫌いなコピペでの操作です。
できればいいんだまずは(;´▽｀A``

実行すると，"元"の図形を１ページ目に３つ　２ページ目に３つつくります。
それぞれShp1～Shp6という名前に変更していて，Shp(i)という変数に収納しています。

なので，前回のコードをあとは絡めれば，Excelのデータからそれぞれの図にデータを流し込んでいけることになる。
１つ一生懸命きれいに作り上げればそれをひな型にどんどん増やせるよ，というコードにしているつもりです。

いろんなことを考えているのでNameArrayというのも今は使っていませんが準備しています。For Nextで回す時になにかつかえるように，と。

あとは，Documents.Add でテンプレートとして使う，という書き方をするのも気に入ってます。イイ書き方ですね。調べているときにどこかで見させてもらったものを流用しています。

Excelでも同じような書き方あるのかなぁ。。

少しずつWordVBAを自分好みに使うよう遊んでいるところです。

異体字に負けにくいWordでの話。

フォントに含まれる字はアプリケーションに依存しないで表示・印刷できると今まで信じていましたが，違うことに今日困らされました。

環境依存文字ったって，Officeでは共通して使えるだろうと思ってましたが，Wordでは出るけどExcelでは出ないとかPublisherでは出るとか，いろいろ。。

Excelがそういう面では汎用性は良くなく，wordがそういうときは強いなぁと感心しながら作ってましたが，

360名分の名簿を表に入れてWordで手動でいじってると　重たい重たい(;´▽｀A``

家で試したら，職場で思ったほどの差はなく，365と2016の違いがあるのかなぁと悩みどころでもあるんですが，外字が使えない職場ではそれなりに戦うしかありません。

軽さではPublisherも惹かれました。レイアウトも崩れにくいし，VBAもexcel,word,powerpointのVBAで遊んでいたせいか，すんなり制御できそう。

ただPublisherというだけで引く人もいる職場です。他のに比べれば私らの職場ではマイナー。

なのでWordの制御をしてみました。

重くなる原因でもありますが，レイアウトフリーでWord上に多数の表を貼り付ける場合，テキストボックスをまず入れて，その中にテーブルを入れてということをします。

テキストボックスに Txt1 という名前をつけて，その中に表を二つ入れている状態で制御した例です。

そういうときの，テキストボックス内のテーブルにアクセスするコードは書いたことが無かったのでとても新鮮でした。

Sub a()

    Dim TBL1 As Table, TBL2 As Table
    With ActiveDocument.Shapes("Txt1").TextFrame.ContainingRange
        Set TBL1 = .Tables(1)
        Set TBL2 = .Tables(2)
    End With

    TBL1.Rows(1).Cells(2).Range.Text = "5"
    
    TBL2.Rows(2).Cells(1).Range.Text = "6"
Stop

End Sub

いつも雑でStopなんかも入れっぱなしですがこんな感じでアクセス可能でした。

ContainingRangeってのは初めて見ましたね。

マクロで表のテンプレートをどんどんコピーして(Duplicateでいけました)座標も調整して，データをExcelから流し込んで，とやってみると，

Excelの苦手分野である印刷と画面表示が違うという困難を乗り越えられる感触が得られました。

Wordで書式を与えられると，Excelで作り直して・・・とされている方々はWordのVBAもやってみることをお勧めしたいと思います。

だいぶ制御できるようになり，とても仕事が楽になったなぁと思う今日この頃です。

ContainingRangeの備忘録として書きました。

テーブルにアクセスするときは

TBL1.Cell(1, 3).Range.Text = "4"

こういう書き方のほうが，Excelやpowerpointに近いですね。
なぜか上では違う書き方をしてしまった。適当さが出てしまう(;´▽｀A``

オートシェイプの線の単純結合(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

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

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

備忘録でした。