| |
Imageオブジェクトを使わずに、ワークシートへ直接4枚づつ、画像ファイルを挿入
していくマクロです。保存先(定数 PFol)フォルダーの下に移動先サブフォルダーを
作り、そこへ4枚づつ移動させてからシートへ挿入します。元保存先のファイル数が
4枚未満になると、作成したサブフォルダーから親フォルダーへファイルを戻し、
そのサブフォルダーを削除して終わります。つまり最初の状態に戻ることになるので、
またそこから実行できますが、とうぜん初期状態として、画像ファイルを最低4枚は
保存しておいて下さい。
なお作業用に作るサブフォルダー以外にも、初期状態でサブフォルダーがあっても
処理に問題ありません。(フォルダー名の頭が "Used" でない限り)
定数 PFol の値を正しく変更してから、試してみて下さい。
Sub Four_Pic_App()
Dim TgAry As Variant
Dim FSO As Object, ObjFol As Object
Dim SFl As Object, F As Object
Dim Ph As String, Ph2 As String
Dim Cnt As Long, i As Long
Dim Lp As Single, Tp As Single
Dim Wp As Single, Hp As Single
Const PFol As String = _
"C:\Documents and Settings\User\My Documents\Picture_Files"
Application.ScreenUpdating = False
With ActiveSheet.Pictures
If .Count > 0 Then .Delete
End With
Set FSO = CreateObject("Scripting.FileSystemObject")
Set ObjFol = FSO.GetFolder(PFol)
TgAry = Array("$A$1", "$F$1", "$A$13", "$F$13")
If ObjFol.SubFolders.Count > 0 Then
If ObjFol.Files.Count < 4 Then
MsgBox "元のフォルダーに保存していた画像は全て表示済み" & _
vbLf & "となりましたので、リセットして終了します。", 64
For Each SFl In ObjFol.SubFolders
If Left$(SFl.Name, 4) = "Used" Then
Ph = PFol & "\" & SFl.Name
FSO.MoveFile Ph & "\*", PFol
FSO.DeleteFolder Ph
End If
Next
GoTo ELine
Else
For Each SFl In ObjFol.SubFolders
If Left$(SFl.Name, 4) = "Used" Then Cnt = Cnt + 1
Next
FSO.CreateFolder PFol & "\Used" & Cnt + 1
For Each F In ObjFol.Files
If LCase(FSO.GetExtensionName(F.Name)) = "jpg" Then
Ph = PFol & "\" & F.Name
Ph2 = PFol & "\Used" & Cnt + 1 & "\" & F.Name
FSO.MoveFile Ph, Ph2
With Range(TgAry(i)).Resize(12, 5)
Lp = .Left: Tp = .Top
Wp = .Width: Hp = .Height
End With
With ActiveSheet.Pictures.Insert(Ph2)
.Left = Lp: .Top = Tp
.Width = Wp: .Height = Hp
End With
i = i + 1: If i > 3 Then Exit For
End If
Next
End If
Else
FSO.CreateFolder PFol & "\Used1"
For Each F In ObjFol.Files
If LCase(FSO.GetExtensionName(F.Name)) = "jpg" Then
Ph = PFol & "\" & F.Name
Ph2 = PFol & "\Used" & Cnt + 1 & "\" & F.Name
FSO.MoveFile Ph, Ph2
With Range(TgAry(i)).Resize(12, 5)
Lp = .Left: Tp = .Top
Wp = .Width: Hp = .Height
End With
With ActiveSheet.Pictures.Insert(Ph2)
.Left = Lp: .Top = Tp
.Width = Wp: .Height = Hp
End With
i = i + 1: If i > 3 Then Exit For
End If
Next
End If
ELine:
Application.ScreenUpdating = True
Set ObjFol = Nothing: Set FSO = Nothing
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
