Excel VBA質問箱 IV

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

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


7897 / 13645 ツリー ←次へ | 前へ→

【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 発言[未読]

【36160】画像表示について
質問  頭が痛い  - 06/3/23(木) 11:48 -

引用なし
パスワード
   現在、ユ−ザ−フォムにて
下記のコ−ドで4枚づつ画像を表示していますが
今後、フォルダ内の画像が増える為、現在のコ−ド
では表示しきれませんので、次・戻るの各コマンドボタン
を使用して4枚づつ画像を表示したいのですが、
御指導のほど、宜しくお願いします。

Private Sub CommandButton2_Click()
 
  Dim i As Long
  myDir = Application.GetOpenFilename("JPEG,*.jpg")
  If VarType(myDir) = vbBoolean Then Exit Sub
  myDir = Left$(myDir, Len(myDir) - Len(Dir(myDir)))
  myFile = Dir(myDir & "*.jpg")
  For i = 1 To 4
    If Len(myFile) > 0 Then
      Set Me("Image" & i).Picture _
        = LoadPicture(myDir & myFile)
      myFile = Dir()
    Else
      Set Me("Image" & i).Picture = Nothing
    End If
  Next

End Sub

【36161】Re:画像表示について
発言  ぱっせんじゃー  - 06/3/23(木) 12:07 -

引用なし
パスワード
   セルなどにカウントアップ、カウントダウン用の番号を出しておき、

↓のようにすればいいのでは、と考えます。
For i = (Worksheets(1).cells(1,1).value -1) + 1 To (Worksheets(1).cells(1,1).value -1)+4

【36162】Re:画像表示について
発言  ぱっせんじゃー  - 06/3/23(木) 12:09 -

引用なし
パスワード
   んん??
私寝ぼけてますね。
どこかに掛け算が入らないといけないのですが・・・。
修正版が出来たらアップします。

【36163】Re:画像表示について
発言  ぱっせんじゃー  - 06/3/23(木) 12:11 -

引用なし
パスワード
   ↓でした。
失礼しました。

For i = (Worksheets(1).cells(1,1).value -1)*4 + 1 To (Worksheets(1).cells(1,1).value -1)*4+4

【36164】Re:画像表示について
発言  ぱっせんじゃー  - 06/3/23(木) 12:14 -

引用なし
パスワード
   既存の画像の削除も入れないとまずいですね。

ほかに画像がなければ

WorkSheets("Sheet1").DrawingObjects.Delete

で全てのシェイプなどが削除されます。

【36165】Re:画像表示について
発言  頭が痛い  - 06/3/23(木) 12:39 -

引用なし
パスワード
   ぱっせんじゃー様、早々の御指導有難うございます。
御指導していただいた方法で作業を進めていきたいと思います。
他の方法がありましたら、また御指導をお願いします。

【36166】Re:画像表示について
発言  ぱっせんじゃー  - 06/3/23(木) 12:46 -

引用なし
パスワード
   よく見たら
i
はイメージコントロールの名前だったんですね。
でしたら私のコードではだめです。

一度画像ファイル名をシートに読込んで、
セルの行番号などをループさせたらいいと思います。

【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

【36206】Re:画像表示について
発言  頭が痛い  - 06/3/24(金) 13:26 -

引用なし
パスワード
   Kein様、御返事が遅れ大変申し訳御座いません。
いろいろ御指導有難う御座います。
現状、初期状態では画像が4枚以下の場合が
ありますが、他の画像を臨時で入れておきます。
また、いろいろ御指導、アドバイス等がございましたら
また御願いします。

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