マニュアル作成に、威力を発揮するのではないでしょうか？
下図は、実行した結果できたEXCELシートです。
Public Sub 自動画像配置()
On Error Resume Next
Dim Rtn As Integer, i As Integer, j As Integer, f As Integer, wPos As Integer
Dim wFiles() As String
Dim wFile As String, wPath As String, wNewFile As String
Rtn = MsgBox("自動画像配置を実行しますか？", vbQuestion + vbYesNo)
If Rtn = vbNo Then
Exit Sub
End If
'フォルダー選択
wFile = InputFolder("画像ファイルのあるフォルダーを選択", , , , "マイ コンピュータ")
If wFile = "" Or wFile = "False" Then
Application.StatusBar = "処理をキャンセルしました。"
Exit Sub
Else
wPath = wFile
End If
'ファイル名の入力
wFile = InputBox("EXCEL出力ファイル名を入力して下さい。", "自動画像配置", "自動画像配置")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'新しいシート（ブック）を追加する
Sheets.Add
Cells.Select
Range("A13").Activate
Selection.ColumnWidth = 2
'文字書式を設定する
Selection.NumberFormatLocal = "@"
'ふぉるだー配下のJPGファイルを取得する
Call GetFiles(wPath, "*.jpg", wFiles())
i = 1
j = 0
'該当ファイル
For f = 0 To UBound(wFiles)
'項番挿入
j = j + 1
Range("A" & i).Select
ActiveCell.FormulaR1C1 = j
Range("B" & i).Select
ActiveCell.FormulaR1C1 = "ＸＸＸＸＸＸ"
'図形挿入
Range("B" & i + 4).Select
ActiveSheet.Pictures.Insert(wFiles(f)).Select
Selection.ShapeRange.ScaleWidth 0.59, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleHeight 0.6, msoFalse, msoScaleFromTopLeft
'項番挿入
j = j + 1
Range("A" & i + 32).Select
ActiveCell.FormulaR1C1 = j
Range("B" & i + 32).Select
ActiveCell.FormulaR1C1 = "ＸＸＸＸＸＸ"
'図形挿入
f = f + 1
Range("B" & i + 36).Select
ActiveSheet.Pictures.Insert(wFiles(f)).Select
Selection.ShapeRange.ScaleWidth 0.59, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleHeight 0.6, msoFalse, msoScaleFromTopLeft
ActiveWindow.LargeScroll ToRight:=-1
'改頁
i = i + 64
Range("A" & i).Select
ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=ActiveCell
Next
wPath = ActiveWorkbook.Path
Sheets("自動画像配置").Select
Sheets("自動画像配置").Copy
Sheets("自動画像配置").Select
Sheets("自動画像配置").Name = wFile
ActiveSheet.PageSetup.PrintArea = ""
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = "&A"
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = "&P/&N"
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.62992125984252)
.RightMargin = Application.InchesToPoints(0.196850393700787)
.TopMargin = Application.InchesToPoints(0.669291338582677)
.BottomMargin = Application.InchesToPoints(0.275590551181102)
.HeaderMargin = Application.InchesToPoints(0.433070866141732)
.FooterMargin = Application.InchesToPoints(0.196850393700787)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlPortrait
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = 98
.FitToPagesWide = 1
.FitToPagesTall = False
End With
wNewFile = ActiveWorkbook.Name
'現在のシートをファイル保存
Workbooks(wNewFile).SaveAs Filename:=wPath & "\" & wFile & ".xls", FileFormat:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
Workbooks(wFile & ".xls").Close
Sheets("自動画像配置").Select
ActiveWindow.SelectedSheets.Delete
Sheets("雛形").Select
Sheets("雛形").Name = "自動画像配置"
Sheets("自動画像配置").Select
Sheets("自動画像配置").Copy After:=Sheets(1)
Sheets("自動画像配置 (2)").Select
Sheets("自動画像配置 (2)").Name = "雛形"
Sheets("自動画像配置").Select
ActiveWorkbook.SaveAs
Workbooks.Open Filename:=wPath & "\" & wFile & ".xls"
Application.StatusBar = "自動画像配置処理が終了しました。"
Application.DisplayAlerts = True
End Sub
ところで、ナンデモ動画サイト EcoTubeというサイトを見つけたのですが、このサイト、結構、お勧めです。
それでは！
