TOP > blog > 名刺をWordで作る VBスクリプト(vbs)で自動組版(7)
word
2018/02/28

名刺をWordで作る VBスクリプト(vbs)で自動組版(7)

管理者用
blog

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

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

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

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

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

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

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

ファイルパスの取得

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

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


'本スクリプトのディレクトリーパスの取得
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 A列の番号欄のデータの有無で行います。

Wordの起動

エクセルに、名刺データが有ると判断してから、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

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

組版と結果の保存

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

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


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

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


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

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

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

 

終了処理

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


		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ファイルには、3つのファイルが有りますが、同じフォルダー内に保存してください。
.vbs ファイルのダブルクリックで、実行します。

'**************************************************************
'* 自動組版 Wordで名刺をレイアウト NO.3          *
'*                              *
'* 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" 'PDFファイル名 名前を使用


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

		'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()'エクセルを閉じる

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

 

関連記事