長く曲がりくねった道　〜　いろいろな話

この広告は30日以上更新がないブログに表示されております。
新規記事の投稿を行うことで、非表示にすることが可能です。

---

※画像をクリックすると拡大表示します

---

１．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

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

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

---

２，ワード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