Excel VBA質問箱 IV

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

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


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

【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 -

引用なし
パスワード
   >同じシートの適当なところに表示(挿入)したいのです。

適当なところ、ではPCは理解してくれません。
明示して表示場所を指定しないといけません。

【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のセルに写真のファイル名を入れて
>という操作については、先にも書いた↓とおり、利口なやり方ではありません。
>>ファイルのパスは正確に入力しなくてはならないのだから、
>>手入力を止めてダイアログから選ぶやり方の方が、確実
>
>>同じシートの適当なところに表示
>どこへどのぐらいの大きさで、ということを具体的に書かないと回答できません。
>繰り返しますが、そーいう点を明確にするためにも「まず一度、試してみて」下さい。
無事、解決しました。
有難うございました。

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