Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


45555 / 76732 ←次へ | 前へ→

【36170】Re:画像表示について
回答  Kein  - 06/3/23(木) 16:05 -

引用なし
パスワード
   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

1 hits

【36160】画像表示について 頭が痛い 06/3/23(木) 11:48 質問
【36161】Re:画像表示について ぱっせんじゃー 06/3/23(木) 12:07 発言
【36162】Re:画像表示について ぱっせんじゃー 06/3/23(木) 12:09 発言
【36163】Re:画像表示について ぱっせんじゃー 06/3/23(木) 12:11 発言
【36164】Re:画像表示について ぱっせんじゃー 06/3/23(木) 12:14 発言
【36165】Re:画像表示について 頭が痛い 06/3/23(木) 12:39 発言
【36166】Re:画像表示について ぱっせんじゃー 06/3/23(木) 12:46 発言
【36170】Re:画像表示について Kein 06/3/23(木) 16:05 回答
【36206】Re:画像表示について 頭が痛い 06/3/24(金) 13:26 発言

45555 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free