「名刺をWordで作る　VBスクリプト（vbs）で自動組版」も（６）まで紹介しました。

・Wordの起動
・用紙サイズの設定
・テキストフレーム操作
　　フォント
　　文字間
　　行間
　　TAB
・画像データのレイアウト

こんな処の紹介だったように思います。

言い換えると、こんな処だけで、結構な自動組版が可能と言う事です。

以前に、エクセルVBAからWordをコントロールすると言う事で、宛名レイアウトを取り上げました。
自由なサイズに対する宛名のレイアウトを可能にしたものです。
合わせて参照頂ければ幸いです。

今回の、自動組版（７）では、エクセルから名刺データをもらってレイアウトを行うところまで考えます。

一人づつの名刺データを手書きで変えながら、ここまで進めて来ました。
エクセルから、データを貰って、連続的に自動組版が出来るようします。
ここまで来ると、自動組版が実感できると思います。

ファイルパスの取得

本スクリプトのフォルダー位置を取得します。
エクセルファイルを同じフォルダーに置いておく事により、スクリプトを書換える必要が無くなります。
また、今回使用している、会社ロゴ画像も同様に同じフォルダーにおきました。

名刺の出力先も同じフォルダー内にしました。

'本スクリプトのディレクトリーパスの取得
Set objFSO = CreateObject("Scripting.FileSystemObject")
CentPasuDesu = objFSO.getParentFolderName(WScript.ScriptFullName)
Set objFSO = Nothing

エクセルで名刺データを用意

まずは、名刺データをエクセルで作成しておきます。
初めは、少ない行数で試して見てください。

次のスクリプト（名刺データ用意）サブルーチンですが、今までは、ここのデータを書き換えてテストして来ました。
当然、このサブルーチンも、エクセルから貰うように書き換える必要が有ります。

'**************************************************************
'*****************　名刺データを用意　*************************
Sub Data_In_Sub()
Dat_namae = "宮本 武蔵"
Dat_Yaku = ""
Dat_Sec1 = "仙台支社"
Dat_Sec2 = "名刺印刷部"
Dat_Sec3 = "名刺課"
Dat_Kata = "担当課長"
Dat_yubin = "142-0053"
Dat_jyusyo = "東京都品川区中延6-1-29"
Dat_tel = "03-3785-4402"
Dat_fax = "03-3785-4401"
Dat_mob="090-335-556"
Dat_mail = "musashi_m"
Dat_url = "http://www.sanei-print.co.jp"
End Sub
'**************************************************************

 エクセルの名刺データ

 エクセルデータを1行づつ読込み、レイアウトをデータが無くなるまで繰り返し処理を行います。
従って、メインルーチンは、データが無くなるまで繰り返す形に書換えます。

エクセルの起動

まず、エクセルを起動します。
次のスクリプトで、VBSからエクセルを起動出来ます。
エクセルは非表示ですが、アクセスが可能となります。

Set objExcel = WScript.CreateObject("Excel.Application") 
Set exlBook = objExcel.WorkBooks.Open("C:\Users\sanei\Desktop\meishiDATA.xls") 
Set exlSheet = exlBook.WorkSheets("Sheet1")

エクセルデータの有無の判断は、　Sheet1　Ａ列の番号欄のデータの有無で行います。

Ｗｏｒｄの起動

エクセルに、名刺データが有ると判断してから、Wordを起動。

Excel_linCunt = 2 'エクセルデータの行を2行目にセット

Excl_DATA = exlSheet.Cells(Excel_linCunt , 1) 'エクセルデータを読み込む

if not Excl_DATA = "" then
	Set myWord = CreateObject("Word.Application")	'エクセルデータが有りの場合、 Word 起動
	myWord.Visible = True ' Word を表示する

ループ処理

データが有る場合、名刺の自動組版を繰り返します。

NotDATA = 1

Do While NotDATA = 1
	Set docWord = myWord.Documents.Add		 ' 新規ドキュメント作成
	call DocSizu()
	'********名刺データを用意　************************************
	'********　名前　ブロック処理　********************************
	'********　肩書き　ブロック処理　******************************
	'********　所属ブロック　処理　********************************
	'********　住所等ブロックの処理　******************************
	'********　社名　ブロック処理　********************************
	'********　ロゴ画像の配置作成　********************************
	'**********メインルーチン終わり'*******************************

	call Data_In_Sub()
		Excl_DATA = exlSheet.Cells(Excel_linCunt , 1) 
		if Excl_DATA = "" then
			NotDATA = 0
		end if
	Loop

エクセルからデータ取込み

名刺データを用意のサブルーチンを以下のように書換えます。
エクセルデータ列の内容に合わせ、セルを指定して各項目の取込みを記述します。

'**************************************************************
'*****************　名刺データを用意　*************************
Sub Data_In_Sub()
	'Excl_DATA = exlSheet.Cells(Excel_linCunt , 1) 
	Dat_namae = exlSheet.Cells(Excel_linCunt , 7) 
	Dat_Yaku = exlSheet.Cells(Excel_linCunt , 6) 
	Dat_Sec1 = exlSheet.Cells(Excel_linCunt , 2) 
	Dat_Sec2 = exlSheet.Cells(Excel_linCunt , 3) 
	Dat_Sec3 = exlSheet.Cells(Excel_linCunt , 4) 
	Dat_Kata = exlSheet.Cells(Excel_linCunt , 5) 
	Dat_yubin = exlSheet.Cells(Excel_linCunt , 13) 
	Dat_jyusyo = exlSheet.Cells(Excel_linCunt , 14) 
	Dat_tel = exlSheet.Cells(Excel_linCunt , 8) 
	Dat_fax =  exlSheet.Cells(Excel_linCunt , 9) 
	Dat_mob = exlSheet.Cells(Excel_linCunt , 10) 
	Dat_mail = exlSheet.Cells(Excel_linCunt , 11) 
	Dat_url = exlSheet.Cells(Excel_linCunt , 12) 
End Sub

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

組版と結果の保存

エクセルから取り込んだデータで１名分の組版を行います。

各サブルーチンは、そのままで変更の必要はありません。

	'********　名前　ブロック処理　********************************
	'********　肩書き　ブロック処理　******************************
	'********　所属ブロック　処理　********************************
	'********　住所等ブロックの処理　******************************
	'********　社名　ブロック処理　********************************
	'********　ロゴ画像の配置作成　********************************
	'**********メインルーチン終わり'*******************************
	'************************************************************

メインルーチン終わりの後ろに、保存等の処理を加えて行きます。
ここでは、レイアウトした名前をファイル名にして保存してます。
同時に、ＰＤＦファイルも作成します。

SevDirWord = "C:\Users\sanei\Desktop" 'フォイルダー
SevFileMei = SevDirWord & "\" & Dat_namae & ".docx" '保存ファイル名　名前を使用
'PDF_FileMei = "\\FXSERVER\v80_hot" & "\" & Dat_namae & ".pdf" 'ホットフォルダーへ書き込む場合
PDF_FileMei = SevDirWord & "\" & Dat_namae & ".pdf" 'ＰＤＦファイル名　名前を使用

docWord.SaveAs2 SevFileMei '・・・・保存
docWord.ExportAsFixedFormat PDF_FileMei,17,False '・・・・・ＰＤＦファイル保存

例では、ディスクトップ上に保存してます。

終了処理

名刺を保存後、ファイルを閉じます。
エクセルの読み込み行をカウントアップ
データの有無をチェックして再び、次のデータ処理に入ります。

		docWord.Close 'ファイルを閉じる
		Excel_linCunt = Excel_linCunt + 1

		Excl_DATA = exlSheet.Cells(Excel_linCunt , 1) 

		if Excl_DATA = "" then
			NotDATA = 0
		end if
	Loop

データが無ければ、ワードを閉じて エクセルも閉じます

	myWord.Quit() 'ワードを閉じる
end if
objExcel.Quit()'エクセルを閉じる

エクセルからデータ読み込み　メインルーチン

スクリプト全体は、ここからダウンロードして参照してください。
全体の中から、今回主に紹介しているメインルーチン部分を次に紹介してます。

スクリプト全体は、　⇒ここ　からダウンロード

 ダウンロードしたZIPファイルには、３つのファイルが有りますが、同じフォルダー内に保存してください。
．ｖｂｓ　ファイルのダブルクリックで、実行します。

'**************************************************************
'* 自動組版　Wordで名刺をレイアウト　NO.３　　　　　　　　　　*
'*　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　*
'*　2018-02-20　　　　　　　　　　　　　　　　　　　　　　　　*
'**********************メインルーチン**************************
Dim myWord, docWord
Dim TextFramCall, gzoFramCall
Dim Dat_namae, Dat_Yaku, Dat_Sec1, Dat_Sec2, Dat_Sec3, Dat_Kata
Dim Dat_yubin, Dat_jyusyo, Dat_tel, Dat_fax, Dat_mob, Dat_mail, Dat_url
Dim objExcel, exlBook, exlSheet, Excel_linCunt
Dim objFSO 

'本スクリプトのディレクトリーパスの取得
Set objFSO = CreateObject("Scripting.FileSystemObject")
CentPasuDesu = objFSO.getParentFolderName(WScript.ScriptFullName)
Set objFSO = Nothing

'エクセルファイルオープン
Set objExcel = WScript.CreateObject("Excel.Application") 
Set exlBook = objExcel.WorkBooks.Open(CentPasuDesu & "\meishiDATA.xls") 
Set exlSheet = exlBook.WorkSheets("Sheet1")

Excel_linCunt = 2

Excl_DATA = exlSheet.Cells(Excel_linCunt , 1) 

if not Excl_DATA = "" then

	Set myWord = CreateObject("Word.Application")	' Word 起動
	myWord.Visible = True ' Word を表示する

	'**************************************************************
	'********　ドキメントを名刺サイズに　**************************

	NotDATA = 1

 	Do While NotDATA = 1

		Set docWord = myWord.Documents.Add		 ' 新規ドキュメント作成
		call DocSizu()

		'********名刺データを用意　************************************
		call Data_In_Sub()
		'********　名前　ブロック処理　********************************
		call Data_namaeOut_Sub()
		set TextFramNamae = TextFramCall
		'********　肩書き　ブロック処理　******************************
		call Data_katagakiOut_Sub()
		set TextFramkatagaki = TextFramCall
		'********　所属ブロック　処理　********************************
		call Data_syozokuOut_Sub()
		set TextFramSec = TextFramCall
		'********　住所等ブロックの処理　******************************
		call Data_jyusyoOut_Sub()
		set TextFramJyusyo = TextFramCall
		'********　社名　ブロック処理　********************************
		call Data_syameiOut_Sub()
		set TextFramSyamei = TextFramCall
		'********　ロゴ画像の配置作成　********************************
		call Data_RogoOut_Sub()
		set Gazo_RogoTram = gzoFramCall

		'**********メインルーチン終わり'*******************************
		'**************************************************************

		SevDirWord = CentPasuDesu 'フォイルダー
		SevFileMei = SevDirWord & "\" & Dat_namae & ".docx" '保存ファイル名　名前を使用
		'PDF_FileMei = "\\FXSERVER\v80_hot" & "\" & Dat_namae & ".pdf" 'ホットフォルダーへ書き込む場合
		PDF_FileMei = SevDirWord & "\" & Dat_namae & ".pdf" 'ＰＤＦファイル名　名前を使用


		docWord.SaveAs2 SevFileMei '・・・・保存
        	docWord.ExportAsFixedFormat PDF_FileMei,17,False '・・・・・ＰＤＦファイル保存

		'msgbox Excl_DATA

		docWord.Close 'ファイルを閉じる
		Excel_linCunt = Excel_linCunt + 1

		Excl_DATA = exlSheet.Cells(Excel_linCunt , 1) 

		if Excl_DATA = "" then
			NotDATA = 0
		end if

	Loop
	myWord.Quit() 'ワードを閉じる
end if
objExcel.Quit()'エクセルを閉じる

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