エクセルからワードの宛名をレイアウトする。名前をレイアウトする。
管理者用
前回までに郵便番号、住所までをレイアウトしました。
オーバーフローの処理が出来ない問題を抱えながら、次の会社名をレイアウトに入ります。
会社名をレイアウトの場合、同時に部署や支店等のセクションも併せて考える必要があります。
また、役職等の肩書き、連名の場合は・・・・なんて広がって行きます。
今回は、範囲を会社名と名前、肩書の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 '１ページに移動
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
先延ばしにしていた溢れ処理（オーバーフロー処理）は、どうしても解決しておく必要があります。
溢れ処理関数（１）
テキストボックスオブジェクトのサイズと文字数から溢れ処理を行います。
背に腹は代えられない気分です。
テキストオブジェクトから、各プロパティーを読み込んでいます。
そして、流し込んでいる文字数とフォントサイズから、テキストボックスに入るフォントサイズを 計算する関数を作って対応しました。
まだ試行錯誤が続いています。
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)
'２－１ Ｏ＿Ｏ＿＿Ｏ＿
'２－２ ＯＯＯＯ
'２－３ Ｏ＿Ｏ＿ＯＯＯ
'１－１ Ｏ＿Ｏ＿
'１－２ Ｏ＿＿Ｏ＿Ｏ＿
'１－３ Ｏ＿ＯＯＯ
'３－１ ＯＯＯ＿Ｏ＿
'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
