Excel VBA質問箱 IV

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

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

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
7995 / 13644 ﾂﾘｰ ←次へ　｜　前へ→
▼ 【35463】複数の写真ファイルの挿入 マイホーム 06/3/5(日) 14:59 質問[未読]
【35473】Re:複数の写真ファイルの挿入 ぱっせんじゃー 06/3/6(月) 10:40 発言[未読]
【35475】Re:複数の写真ファイルの挿入 ぱっせんじゃー 06/3/6(月) 13:39 発言[未読]
【35500】ぱっせんじゃーさんへ マイホーム 06/3/6(月) 22:24 質問[未読]
【35529】Re:複数の写真ファイルの挿入 Kein 06/3/7(火) 14:06 回答[未読]
【35573】Re:複数の写真ファイルの挿入 マイホーム 06/3/7(火) 21:32 質問[未読]
【35581】Re:複数の写真ファイルの挿入 ぱっせんじゃー 06/3/8(水) 7:56 発言[未読]
【35584】Re:複数の写真ファイルの挿入 ぱっせんじゃー 06/3/8(水) 8:23 発言[未読]
【35642】Re:複数の写真ファイルの挿入 マイホーム 06/3/8(水) 21:56 お礼[未読]
【35603】Re:複数の写真ファイルの挿入 Kein 06/3/8(水) 13:46 発言[未読]
【35643】Re:複数の写真ファイルの挿入 マイホーム 06/3/8(水) 21:59 お礼[未読]
【35463】複数の写真ファイルの挿入
質問  マイホーム  - 06/3/5(日) 14:59 -
引用なし
パスワード
   Private Sub Worksheet_Change(ByVal Target As Range)

Dim ファイル As String

If Intersect(Target, Range("B2")) Is Nothing Then Exit Sub

ActiveSheet.Shapes("画像1").Delete

ファイル = "I:\雑誌\" & Range("B2").Value & ".jpg"

Range("D4").Select

　　ActiveSheet.Pictures.Insert(ファイル).Select
　　
　　Selection.ShapeRange.LockAspectRatio = msoTrue
　　
　　Selection.ShapeRange.Height = 270#
　　
　　Selection.Name = "画像1"

End　Sub

上記マクロを同じシートに2枚以上の写真ファイルを挿入できるように
編集したいのですが、どのようにすればいいのか教えてください。
【35473】Re:複数の写真ファイルの挿入
発言  ぱっせんじゃー  - 06/3/6(月) 10:40 -
引用なし
パスワード
   読込む画像ファイル名はセルを参照しているようですので、

For〜Next

で参照するセル、シェイプ名、シェイプを貼り付ける位置
をずらしながら処理するようにすればいいのではないでし
ょうか。
【35475】Re:複数の写真ファイルの挿入
発言  ぱっせんじゃー  - 06/3/6(月) 13:39 -
引用なし
パスワード
   画像ファル名の頭に"DSCF" と入っていると仮定します。

B2に
1
と入力すると、

DSCF0001〜DSCF0010

をシートに取込みます。


Private Sub Worksheet_Change(ByVal Target As Range)
Dim ファイル As String
Dim i As Long
　If Intersect(Target, Range("B2")) Is Nothing Then Exit Sub
　'全てのシェイプの削除
　ActiveSheet.DrawingObjects.Delete
　 '画像ファイル名が連番でないとエラーになる
　 For i = 1 To 10
　　　 ファイル = "I:\雑誌\" & "DSCF" & Format(Target.Value + i - 1, "0000") & ".jpg"
　　　 'シェイプ名を連番でつける
　　　 ActiveSheet.Pictures.Insert(ファイル).Name = "画像" & i

　　　 With ActiveSheet.Shapes("画像" & i)
　　　　'i = 1だったら
　　　　If i = 1 Then
　　　　　　'シェイプのTopをD4セルのTopに設定
　　　　　 .Top = ActiveSheet.Cells(4, 4).Top
　　　　Else 'i>1だったら
　　　　　 'シェイプのTopを前の画像の下に設定
　　　　　 .Top = ActiveSheet.Shapes("画像" & i - 1).Top + ActiveSheet.Shapes("画像" & i - 1).Height
　　　　End If
　　　　 'LeftをD4セルのLeftに設定
　　　　.Left = ActiveSheet.Cells(4, 4).Left
　　　　.LockAspectRatio = msoTrue
　　　　.Height = 270#
　　　 End With
　 Next i
End Sub
【35500】ぱっせんじゃーさんへ
質問  マイホーム  - 06/3/6(月) 22:24 -
引用なし
パスワード
   ▼ぱっせんじゃー さん：
>読込む画像ファイル名はセルを参照しているようですので、
>
>For〜Next
>
>で参照するセル、シェイプ名、シェイプを貼り付ける位置
>をずらしながら処理するようにすればいいのではないでし
>ょうか。
ぱっせんじゃーさん、二度も回答して頂き有難うございます。
申し訳ありませんが、再度教えていただきたいのですが
同じシートに、それぞれのセルを参照して二枚の写真を挿入するにはどの様にすればいいのですか？
VBA初心者なもので、宜しくお願いします。
【35529】Re:複数の写真ファイルの挿入
回答  Kein  - 06/3/7(火) 14:06 -
引用なし
パスワード
   例えば D4 以下に「6行・3列の大きさ」で「1行空白をおいて」画像を挿入していく、
というコードなら

Sub Pic_Ins()
　 Dim MyF As String
　 Dim xR As Long
　 Dim Lp As Single, Tp As Single
　 Dim Wp As Single, Hp As Single
　
　 ChDir "C:\Documents and Settings\User" & _
　 "\My Documents\My Pictures\画像資料"
　 With Application
　　　MyF = .GetOpenFilename("画像ファイル(*.jpg),*.jpg")
　　　If MyF = "False" Then GoTo ELine
　　　.ScreenUpdating = False
　 End With
　 With ActiveSheet
　　　If .Pictures.Count = 0 Then
　　　　 xR = 4
　　　Else
　　　　 xR = .Pictures.Count * 7 + 4
　　　End If
　　　With .Cells(xR, 4).Resize(6, 3)
　　　　 Lp = .Left: Tp = .Top
　　　　 Wp = .Width: Hp = .Height
　　　End With
　　　With .Pictures.Insert(MyF)
　　　　 .Left = Lp: .Top = Tp
　　　　 .Width = Wp: .Height = Hp
　　　End With
　 End With
ELine:
　 With Application
　　　ChDir .DefaultFilePath
　　　.ScreenUpdating = True
　 End With
End Sub

などとします。
どんなコードにするにせよ、ファイルのパスは正確に入力しなくてはならないのだから、
手入力を止めてダイアログから選ぶやり方の方が、確実と思います。
【35573】Re:複数の写真ファイルの挿入
質問  マイホーム  - 06/3/7(火) 21:32 -
引用なし
パスワード
   ▼Kein さん：
>例えば D4 以下に「6行・3列の大きさ」で「1行空白をおいて」画像を挿入していく、
>というコードなら
>
>Sub Pic_Ins()
>　 Dim MyF As String
>　 Dim xR As Long
>　 Dim Lp As Single, Tp As Single
>　 Dim Wp As Single, Hp As Single
>　
>　 ChDir "C:\Documents and Settings\User" & _
>　 "\My Documents\My Pictures\画像資料"
>　 With Application
>　　　MyF = .GetOpenFilename("画像ファイル(*.jpg),*.jpg")
>　　　If MyF = "False" Then GoTo ELine
>　　　.ScreenUpdating = False
>　 End With
>　 With ActiveSheet
>　　　If .Pictures.Count = 0 Then
>　　　　 xR = 4
>　　　Else
>　　　　 xR = .Pictures.Count * 7 + 4
>　　　End If
>　　　With .Cells(xR, 4).Resize(6, 3)
>　　　　 Lp = .Left: Tp = .Top
>　　　　 Wp = .Width: Hp = .Height
>　　　End With
>　　　With .Pictures.Insert(MyF)
>　　　　 .Left = Lp: .Top = Tp
>　　　　 .Width = Wp: .Height = Hp
>　　　End With
>　 End With
>ELine:
>　 With Application
>　　　ChDir .DefaultFilePath
>　　　.ScreenUpdating = True
>　 End With
>End Sub
>
>などとします。
>どんなコードにするにせよ、ファイルのパスは正確に入力しなくてはならないのだから、
>手入力を止めてダイアログから選ぶやり方の方が、確実と思います。
すみません、せっかく答えて頂いたのに
素人なのでよくわかりません。
具体的に、B2とB3のセルに写真のファイル名を入れて、
同じシートの適当なところに表示(挿入)したいのです。
本当に申し訳ありませんが、教えて頂きませんか？
【35581】Re:複数の写真ファイルの挿入
発言  ぱっせんじゃー  - 06/3/8(水) 7:56 -
引用なし
パスワード
   >同じシートの適当なところに表示(挿入)したいのです。

適当なところ、ではＰＣは理解してくれません。
明示して表示場所を指定しないといけません。
【35584】Re:複数の写真ファイルの挿入
発言  ぱっせんじゃー  - 06/3/8(水) 8:23 -
引用なし
パスワード
   B2、B3セルを参照して画像挿入するサンプルです。

Sub gazou()
Dim c As Range
Dim i As Long
Dim Fmei As String
Dim MyTop As Single
Dim MyLeft As Single
　ActiveSheet.DrawingObjects.Delete
　For Each c In ActiveSheet.Range("B2:B3") '参照セルをB2:B3と指定
　 i = i + 1
　 Fmei = "I:\雑誌\" & c.Value & ".jpg"
　 If Dir(Fmei) = "" Then '画像ファイルが存在しない場合
　　　MsgBox "指定の画像ファイルは存在しません。" & vbCrLf & "処理を中止します。"
　　　Exit Sub
　 Else
　　　ActiveSheet.Pictures.Insert(Fmei).Name = "画像" & i
　　　With ActiveSheet.Shapes("画像" & i)
　　　.LockAspectRatio = msoTrue
　　　.Height = 270#
　　　If i = 1 Then
　　　　 MyTop = ActiveSheet.Cells(4, 4).Top
　　　Else
　　　　 MyTop = ActiveSheet.Shapes("画像" & i - 1).Top + _
　　　　　　　　 ActiveSheet.Shapes("画像" & i - 1).Height
　　　End If
　　 .Top = MyTop
　　　End With
　 End If
　Next
End Sub
【35603】Re:複数の写真ファイルの挿入
発言  Kein  - 06/3/8(水) 13:46 -
引用なし
パスワード
   >"C:\Documents and Settings\User" & _
>"\My Documents\My Pictures\画像資料"
というところを、画像ファイルを保存しているパスに変更して実行するだけです。
まず一度、試してみてからレスして下さい。

>B2とB3のセルに写真のファイル名を入れて
という操作については、先にも書いた↓とおり、利口なやり方ではありません。
>ファイルのパスは正確に入力しなくてはならないのだから、
>手入力を止めてダイアログから選ぶやり方の方が、確実

>同じシートの適当なところに表示
どこへどのぐらいの大きさで、ということを具体的に書かないと回答できません。
繰り返しますが、そーいう点を明確にするためにも「まず一度、試してみて」下さい。
【35642】Re:複数の写真ファイルの挿入
お礼  マイホーム  - 06/3/8(水) 21:56 -
引用なし
パスワード
   ▼ぱっせんじゃー さん：
>B2、B3セルを参照して画像挿入するサンプルです。
>
>Sub gazou()
> Dim c As Range
> Dim i As Long
> Dim Fmei As String
> Dim MyTop As Single
> Dim MyLeft As Single
>　ActiveSheet.DrawingObjects.Delete
>　For Each c In ActiveSheet.Range("B2:B3") '参照セルをB2:B3と指定
>　 i = i + 1
>　 Fmei = "I:\雑誌\" & c.Value & ".jpg"
>　 If Dir(Fmei) = "" Then '画像ファイルが存在しない場合
>　　　MsgBox "指定の画像ファイルは存在しません。" & vbCrLf & "処理を中止します。"
>　　　Exit Sub
>　 Else
>　　　ActiveSheet.Pictures.Insert(Fmei).Name = "画像" & i
>　　　With ActiveSheet.Shapes("画像" & i)
>　　　.LockAspectRatio = msoTrue
>　　　.Height = 270#
>　　　If i = 1 Then
>　　　　 MyTop = ActiveSheet.Cells(4, 4).Top
>　　　Else
>　　　　 MyTop = ActiveSheet.Shapes("画像" & i - 1).Top + _
>　　　　　　　　 ActiveSheet.Shapes("画像" & i - 1).Height
>　　　End If
>　　 .Top = MyTop
>　　　End With
>　 End If
>　Next
>End Sub
おかげさまで、解決しました。
何度も申し訳ありません、
本当に有難うございました。
【35643】Re:複数の写真ファイルの挿入
お礼  マイホーム  - 06/3/8(水) 21:59 -
引用なし
パスワード
   ▼Kein さん：
>>"C:\Documents and Settings\User" & _
>>"\My Documents\My Pictures\画像資料"
>というところを、画像ファイルを保存しているパスに変更して実行するだけです。
>まず一度、試してみてからレスして下さい。
>
>>B2とB3のセルに写真のファイル名を入れて
>という操作については、先にも書いた↓とおり、利口なやり方ではありません。
>>ファイルのパスは正確に入力しなくてはならないのだから、
>>手入力を止めてダイアログから選ぶやり方の方が、確実
>
>>同じシートの適当なところに表示
>どこへどのぐらいの大きさで、ということを具体的に書かないと回答できません。
>繰り返しますが、そーいう点を明確にするためにも「まず一度、試してみて」下さい。
無事、解決しました。
有難うございました。
  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
7995 / 13644 ﾂﾘｰ ←次へ　｜　前へ→
ページ：  ┃  記事番号：
2610219
(SS)C-BOARD v3.8 is Free