TOP > blog > エクセルからワードの宛名をレイアウトする。名前をレイアウトする。
宛名印刷
2017/03/12

エクセルからワードの宛名をレイアウトする。名前をレイアウトする。

管理者用
blog

前回までに郵便番号、住所までをレイアウトしました。
オーバーフローの処理が出来ない問題を抱えながら、次の会社名をレイアウトに入ります。

会社名をレイアウトの場合、同時に部署や支店等のセクションも併せて考える必要があります。
また、役職等の肩書き、連名の場合は・・・・なんて広がって行きます。

今回は、範囲を会社名と名前、肩書の3つの項目に絞った単純な形でですすめます。

ここで、レイアウト仕様を明確にしておく必要があります。

  • 個人名のみの場合
  • 会社名のみの場合
  • 会社名と個人名の場合
  • 会社名と個人名と肩書が入る場合

・会社名及び個人名のみの場合は、はがきの中心に配置。
・敬称を名前の場合は様、会社の場合は御中。
・会社と名前が有る場合は、名前ははがきの中心に、会社は名前の右側に配置。
・名前に、肩書がついている場合、名前の上に配置。肩書が長い場合は、名前の右側に配置。

レイアウト位置は、事前にシュミレーションしておき、大まかな位置を確認しておくと良いでしょう。

レイアウト位置が決まれば、その座標にテキストボックスを作って、データを流し込むだけです。

会社と名前と肩書きとなると、長くなりそうなので、今日は、名前の配置に絞って進めます。

住所データは、以下のエクセルデータです。

メインのスクリプトは、前回までのものに、 名前処理への部分を追加しただけです。

名前処理の部分は、関数化しました。
ワードオブジェクトと、会社、肩書き、名前のデータを渡しています。

 AA = namae_Layout(myWord, docWord, kaisya_DAT, katagaki_DAT, namae_DAT) '名前会社のレイアウト

 <メインのマクロ>

Sub kaisya()

    Dim myWord As New Word.Application         ' Word 起動
    Dim docWord As Document
   ' Dim docSelection
    
    Set myWord = CreateObject("Word.Application")
    Set docWord = myWord.Documents.Add
    Set docSelec = myWord.Selection
        
    myWord.Visible = True ' Word を表示する

    '******************************************************
    Rem   ブックのサイズをはがきサイズに ========

    CC = yoshi_size(docWord, "はがき")

    '******************************************************

    MaxGyo = Range("A1").End(xlDown).Row '行数 データ件数を調べる

    For Ab = 1 To MaxGyo - 2 'データ分のページ作成
        docSelec.InsertNewPage
    Next
    
    docSelec.GoTo What:=wdGoToPage, Which:=1  '1ページに移動

    For gyoNo = 1 To MaxGyo - 1

        yubin_DAT = Sheet1.Cells(gyoNo + 1, 5)
        jyusyo1_DAT = Sheet1.Cells(gyoNo + 1, 6)
        jyusyo2_DAT = Sheet1.Cells(gyoNo + 1, 7)
        kaisya_DAT = Sheet1.Cells(gyoNo + 1, 2)
        namae_DAT = Sheet1.Cells(gyoNo + 1, 4)
        katagaki_DAT = Sheet1.Cells(gyoNo + 1, 3)
                
        '******************************************************
        Rem  郵便番号の配置

        If Not yubin_DAT = "" Then
            yubin_DAT = yubin_del(yubin_DAT) '郵便番号の正規化
            AA = yubin_Layout(docWord, yubin_DAT) '郵便番号のレイアウト
        End If
        Rem 郵便番号の配置 END
        '******************************************************
        Rem  住所の配置
        
            AA = jyusyo_Layout(docWord, jyusyo1_DAT, jyusyo2_DAT)  '住所のレイアウト

        Rem 住所の配置 END
        '******************************************************
        Rem  名前・会社の配置
        kaisya_DAT = Sheet1.Cells(gyoNo + 1, 2)
        namae_DAT = Sheet1.Cells(gyoNo + 1, 4)
        katagaki_DAT = Sheet1.Cells(gyoNo + 1, 3)
         
        AA = namae_Layout(myWord, docWord, kaisya_DAT, katagaki_DAT, namae_DAT) '名前・会社のレイアウトへ

        Rem 名前・社の配置 END
        '******************************************************



        docSelec.GoTo What:=wdGoToPage, Which:=wdGoToNext
        
    Next
End Sub

名前処理の関数ですが、先の事も考え、会社や肩書の処理も書けるようにしてます。
テキストボックスを作る処理も関数化する必要があるかもしれませんが、 しばらくは、このままで行きます。

<溢れ処理が入っていない時の実行結果>

テキストボックスは、均等配置に設定してます。
佐々木小次郎から様が消えています。
テキストボックスに入り切らなかった為、見えないだけです。

 名前処理のマクロ


Function namae_Layout(myWord, docWord, kaisya_DAT, katagaki_DAT, namae_DAT)

    If Not namae_DAT = "" Then
        '名前有り
        samaontyu = "様"
        namaeSekika = namae_sm(namae_DAT, samaontyu)
        namae_DAT = namaeSekika(6)

                    
            font_p = 36 '
            Topichi = 26 + 14
            Botichi = 24
            RENDichi = 10

            namae_XS = MillimetersToPoints((100 / 2) - ((font_p * 0.35) / 2))
            namae_YS = MillimetersToPoints(Topichi)
            XW = MillimetersToPoints((font_p * 0.35) * 1 + 1)
            YH = MillimetersToPoints(148 - Topichi - Botichi)

            Set TextFramAN = docWord.Shapes.AddTextbox _
   (Orientation:=msoTextOrientationVerticalFarEast, Left:=namae_XS, Top:=namae_YS, Width:=XW, Height:=YH)
            TextFramAN.TextFrame.TextRange.Text = namae_DAT 'データを書き込む
            TextFramAN.TextFrame.TextRange.Font.Size = font_p
            TextFramAN.TextFrame.TextRange.Font.Name = "HG正楷書体"

            With TextFramAN.TextFrame.TextRange.ParagraphFormat
                .SpaceBefore = 0    '前のスペース
                .SpaceBeforeAuto = False
                .SpaceAfter = 0 '後のスペース
                .SpaceAfterAuto = False
                .LineSpacingRule = wdLineSpaceExactly   '行間隔モード
                .LineSpacing = font_p   '行間隔
                .Alignment = 4   '揃え方向 0 '揃え方向  Alignment = 2
            End With

            With TextFramAN.TextFrame
                .VerticalAnchor = msoAnchorTop
                .MarginBottom = 0
                .MarginLeft = 0
                .MarginRight = 0
                .MarginTop = 0
            End With
            
            TextFramAN.TextFrame.AutoSize = True 'テキストボックスをオートサイズに設定
            TextFramAN.Line.Visible = msoFalse '枠線無しにCreator
            'MsgBox TextFramAN.TextFrame.TextRange.Paragraphs.Count '段落数を調べる
            
            AAAAAA = ovftxtbox(TextFramAN, XW)

       
        If kaisya_DAT = "" Then
            '名前のみ この部分は使わないと思いますが
 
        Else
         '会社 名前 が有る時の処理
            If Not katagaki_DAT = "" Then
         
             '肩書有り

            Else
             '肩書無し

            End If
            
        End If
    Else
        '会社のみの時の処理を記入
    
    End If

    namae_Layout = 1
    
End Function

先延ばしにしていた溢れ処理(オーバーフロー処理)は、どうしても解決しておく必要があります。

溢れ処理関数(1) 
テキストボックスオブジェクトのサイズと文字数から溢れ処理を行います。 
背に腹は代えられない気分です。 
テキストオブジェクトから、各プロパティーを読み込んでいます。 

そして、流し込んでいる文字数とフォントサイズから、テキストボックスに入るフォントサイズを 計算する関数を作って対応しました。
まだ試行錯誤が続いています。


Function ovftxtbox(TextFramAN)
	namae_DAT = TextFramAN.TextFrame.TextRange.Text     
	font_p = TextFramAN.TextFrame.TextRange.Font.Size
	AA = Len(namae_DAT) * font_p * 0.35
	BB = PointsToMillimeters(YH)
 	If AA > BB Then
		pointZ = BB / Len(namae_DAT) / 0.35
		TextFramAN.TextFrame.TextRange.Font.Size = pointZ
	 End If
 End Function

溢れは、何とか解消しました。
名前の配置をどうしようかと悩んでいる所です。姓名の間のスペースが気になります。
それで、名前の正規化スクリプトを用意しました。
姓名の文字数により、スペースを入れて見た目バランス良く調整しました。
他の方法も考えられますが、この時点では、こんな関数にしておきました。
尚、戻り値として、余計なものまでついてますが、いずれ使う事になる事を想定してます。


・・・・・試行錯誤が続いています。

名前の正規化マクロ


Function namae_sm(moji)
'2-1 O_O__O_
'2-2 OOOO
'2-3 O_O_OOO
'1-1 O_O_
'1-2 O__O_O_
'1-3 O_OOO
'3-1 OOO_O_
'Dim sp, nm1, nm2, nmch_1, nmch_2, nmch_3, nmch_4, nmch_5, nmch_6, bak_1, sp_sp As String
'Dim len_1, len_2

sp_sp = " "
mae_cs = 0
usiro_sp = 0
    moji = LTrim(moji)   '両端スペース削除
    moji = RTrim(moji)
    bak_1 = moji
    moji = sp1_1(moji)
    'moji = StrConv(moji, 4)
    sp = InStr(1, moji, " ", 1)

    If sp = 0 Then
        nm1 = moji
        nm2 = ""
    Else
        nm1 = Mid(moji, 1, sp - 1)
        nm2 = Mid(moji, sp + 1)
    End If

    nm1 = LTrim(nm1)   '両端スペース削除
    nm1 = RTrim(nm1)
    nm2 = LTrim(nm2)   '両端スペース削除
    nm2 = RTrim(nm2)
    bak_1 = ""
    len_1 = Len(nm1)
    len_2 = Len(nm2)
    
      Select Case len_1
  
            Case 1
                 nmch_1 = Mid(nm1, 1, 1)
            Case 2
                 nmch_1 = Mid(nm1, 1, 1)
                 nmch_2 = Mid(nm1, 2, 1)
            Case 3
                 nmch_1 = Mid(nm1, 1, 1)
                 nmch_2 = Mid(nm1, 2, 1)
                 nmch_3 = Mid(nm1, 3, 1)
            Case Else
        End Select
  Select Case len_2
            Case 1
                 nmch_4 = Mid(nm2, 1, 1)
            Case 2
                 nmch_4 = Mid(nm2, 1, 1)
                 nmch_5 = Mid(nm2, 2, 1)
            Case 3
                 nmch_4 = Mid(nm2, 1, 1)
                 nmch_5 = Mid(nm2, 2, 1)
                 nmch_6 = Mid(nm2, 3, 1)
            Case Else
        End Select

  Select Case len_1
            Case 1
              Select Case len_2
                Case 1
                     bak_1 = nmch_1 + " " + nmch_4 + " "
                Case 2
                     bak_1 = nmch_1 + "  " + nmch_4 + " " + nmch_5 + ""
                Case 3
                     bak_1 = nmch_1 + "  " + nmch_4 + nmch_5 + nmch_6
                Case Else
            
                End Select
            Case 2
              Select Case len_2
              
                Case 1
                     bak_1 = nmch_1 + " " + nmch_2 + "   " + nmch_4 + ""
                Case 2
                     bak_1 = nmch_1 + " " + nmch_2 + " " + nmch_4 + " " + nmch_5
                Case 3
                     bak_1 = nmch_1 + " " + nmch_2 + " " + nmch_4 + nmch_5 + nmch_6
                Case Else
                End Select
  
            Case 3
              Select Case len_2
                Case 1
                     bak_1 = nmch_1 + nmch_2 + nmch_3 + "  " & nmch_4 + ""
                Case 2
                     bak_1 = nmch_1 + nmch_2 + nmch_3 + " " + nmch_4 + " " + nmch_5
                Case 3
                     bak_1 = nmch_1 + nmch_2 + nmch_3 + nmch_4 + nmch_5 + nmch_6
                Case Else
            
                End Select
            Case Else
        End Select

     namae_sm = Array(nm1 & nm2, len_1, len_2, len_1 + len_2, nm1, nm2, bak_1)

End Function

 テキストボックス溢れ処理マクロ

溢れ処理は、何とか解消したように見えます。名前の姓名の数によるレイアウトも上手くいきました。

しかし、溢れ処理には、フォントサイズを落とす事以外にも、文字間を詰める。文字を平体にする。
枠を広げるなどの方法が考えられます。
やはり、流し込んだ状態の情報が必要です。
テキストボックス内の段落数は見られるのですが、見た目の行数を返すプロパティーが見つかりません。
また、溢れているなどの情報のプロパティも見つかりません。

それが、ついに見つけました。

試行錯誤の連続でした。
ようやく、その方法を考えだしました。

テキストボックスのサイズをオートにしておき、サイズの変化を見て判断できる事に気が付きました。

一時は、テキストボックスを使わないで、レイアウトして行く事も考えましたが、とりあえず良しとしましょう。

テキストボックスのサイズオートに設定しているため、1行に収まらないと行が広がります。
広がったかどうかで、溢れを見つける事が出来るのです。
たぶん、だれも気が付いていないと思います。

そんな事しなくても、機能として持っている?

だったら、今まで何をやってたんだって事になりますが・・・・・・・・・・・・・。

その時は、勉強不足でごめんなさい。と言うだけです。

 


Function ovftxtbox(TextFramAN, XW)
     namae_XS = TextFramAN.Left 'Xスタート
     namae_YS = TextFramAN.Top 'Yスタート
     XW2 = TextFramAN.Width '幅
     YH = TextFramAN.Height '高
     'MsgBox namae_XS & "   " & namae_YS & "   " & XW & "   " & YH
     namae_DAT = TextFramAN.TextFrame.TextRange.Text     'データを取り込む
     font_p = TextFramAN.TextFrame.TextRange.Font.Size
     font_mei = TextFramAN.TextFrame.TextRange.Font.Name
  ovftxtbox = 0
  If XW2 > XW Then
    ovftxtbox = 1
     font_pZ = font_p
  End If
   ovftxtbox = 0
 'オーバーフローしているか調査、 フォントサイズを小さくする
 Do While ovftxtbox = 1
        font_pZ = font_pZ - 0.5 '0.5ポイントづつ
        TextFramAN.TextFrame.TextRange.Font.Size = font_pZ
        XW2 = TextFramAN.Width
        
        If XW2 <= XW Then
            ovftxtbox = 0
            Exit Do
        End If
 Loop

End Function

関連記事