2016年05月12日

ワードマクロの作成


ブログはワードで原稿を作っている。

出来上がった原稿はブログの編集画面に

コピー・貼り付けをする。

原稿ではブログの体裁も確認したいので、

画像も挿入する。

しかし原稿からブログに貼り付けた場合、

文字だけしか貼り付かない。

画像は別ルートでアップロードしておく必要がある。

そしてブログの編集画面でその画像を選択し、

挿入されたタグを再利用する。

ブログ編集プログラムにより作成されたタグを

コピー・貼り付けし、画像を特定する

ファイル名だけを正式名に変更する。

だから原稿に画像のファイル名が必要になる。

今まではファイル名と画像は別々に貼り付けていた。

しかし画像が増えるとこの作業が面倒になる。

コピー・貼り付けに使う時間を

原稿の文章を考える時間に割り当てたい。

かくして、ワードマクロの作成に至ったのである。

エクセルのマクロは仕事で結構作ってはいたが、

ワードのマクロは面倒だと言う先入観を持っていた。

だからワードのマクロは作ったことがない。

だが画像を20枚以上文章に挿入しようとすると、

ちょっと躊躇する。

そしてだんだん画像の枚数を調整してくるようになる。

これではいけない、と言うことで自動化を考えてみた。

なぜ面倒だと思っていたのかは実際作ってみると解る。

同じマイクロソフトの

それもOfficeのグループでありながら、

エクセルとは使い方が微妙に違う。

この話はこの位にしておこう。



処理ステップは2つに分かれる。

1つ目は、VBSによりファイル名の一覧表を作成する。

以前投稿したVBSを少し変更した。

2つ目でワードのマクロを起動し、

VBSで作成したファイル名一覧表を読み込み、

ワードにファイル名と画像を挿入する。

画像はフルサイズでは文章が書けないので、

少し縮小する。

以下がVBSとVBAである。






1.VBSによるファイル名の一覧ファイル作成

'==========================================================
'フォルダ内をサーチし、リストアップ
'対象フォルダにこのスクリプトを配置し、スクリプトを実行する
'
'==========================================================
'
'フォルダ名にスペースが入っているとエラーになる
'
Const cOutFiNa = "FolderList2.txt" '出力ファイル名
dim FS
dim xMyPath

set FS=CreateObject("Scripting.FileSystemObject")
'スクリプトの入っているフォルダ名を取得
xMyPath=Replace(WScript.ScriptFullName, WScript.ScriptName, vbNullString)
if right(xMyPath,1)="\" then '右端が"\"の場合、この"\"を削除
xLen=Len(xMyPath)
xMyPath=left(xMyPath,(xLen-1))
end if

Call FileListOutProc(xMyPath,cOutFiNa)

set FSN = Nothing

'--------------------------------------------------
' ファイル名のリストアップ
'--------------------------------------------------
'カンマ区切りで1レコードを出力する

Function FileListOutProc(pSourceFolder,pFileName)
dim objFolder,objFiles
dim objOutFile
dim arr
dim tmp

Set objFolder = FS.GetFolder(pSourceFolder)
Set objFiles = objFolder.Files
Set objOutFile = FS.OpenTextFile(pFileName,2,True)

tmp=""
For Each Fi in objFiles
arr=split(Fi.Name,".")

if ubound(arr)=>1 then
'JPGだけを対象とする
if instr("JPGjpg",arr(1))>0 then
tmp=tmp & Fi.Name & ","
end if
end if
Next
objOutFile.WriteLine tmp
objOutFile.Close

set objOutFile = Nothing
Set objFiles = Nothing
Set objFolder = Nothing

End Function



2,ワードVBAによるファイル名と画像の挿入

Option Explicit

'画像処理
'=========
Sub PicPro()
Call PicInsert
Call PicResize
End Sub

'画像とファイル名の挿入
'======================
Sub PicInsert()
Const infoFileNa = "FolderList2.txt" 'ファイル名一覧ファイル
Dim arr() As String
Dim myPath As String
Dim infoPath As String
Dim x As Integer
Dim tmp As String
Dim xShape As Shape

myPath = ActiveDocument.Path & "\"
infoPath = myPath & "\" & infoFileNa

Open infoPath For Input As #1
Do Until EOF(1)
Line Input #1, tmp
Loop
Close #1

arr = Split(tmp, ",")

For x = 0 To (UBound(arr) - 1)
'ファイル名の挿入
Selection.TypeText Text:=arr(x) & vbCrLf

'画像の挿入
Selection.InlineShapes.AddPicture FileName:= _
myPath & arr(x), LinkToFile:=False, _
SaveWithDocument:=True

'改行
Selection.TypeText vbCrLf & vbCrLf & vbCrLf
Next
Set xShape = Nothing
End Sub

'表示画像の縮小
'===============
Sub PicResize()
Const one_mm = 0.35 '1ポイントのサイズ mm
Dim xIS As InlineShape

'全ての画像を洗い出す
For Each xIS In ActiveDocument.InlineShapes
xIS.LockAspectRatio = msoTrue
xIS.Height = 50 / one_mm '画像の高さを 50mmとした
Next
End Sub






posted by kaz at 02:07 | Comment(0) | TrackBack(0) | コンピュータ
この記事へのコメント
コメントを書く

お名前:

メールアドレス:


ホームページアドレス:

コメント:

※ブログオーナーが承認したコメントのみ表示されます。

この記事へのトラックバックURL
http://fanblogs.jp/tb/5054200
※ブログオーナーが承認したトラックバックのみ表示されます。

この記事へのトラックバック
リンク
access:
online:
ファン
検索
<< 2019年02月 >>
          1 2
3 4 5 6 7 8 9
10 11 12 13 14 15 16
17 18 19 20 21 22 23
24 25 26 27 28    
最新記事
最新コメント
ドローンを修理する by kaz (03/14)
ドローンを修理する by obayashi (03/10)
タグクラウド
カテゴリアーカイブ
プロフィール