解決済み

エクセルVBAでの画像ファイル名取得他

  • 暇なときにでも
  • 質問No.4443857
  • 閲覧数12588
  • ありがとう数5
  • 気になる数0
  • 回答数3
  • コメント数0

お礼率 71% (5/7)

VBAについての質問です。
http://hp.vector.co.jp/authors/VA033788/kowaza.html#0158
上記をベースに、なんとかVBAを下記のように書き換えました。

Sub LoadPictures3()
Dim Fnames As Variant
Dim Fn As Variant
Dim i As Integer
Dim Pic As Picture
Dim R As Range
Dim R2 As Range
Dim Pc As Integer

Fnames = Application.GetOpenFilename("図(*.jpg;*.gif),*.jpg;*.gif", MultiSelect:=True)
If TypeName(Fnames) = "Boolean" Then Exit Sub

Application.ScreenUpdating = False

'一枚目の貼付け位置
Set R = Range("B5")
Set R2 = R.Offset(35)
Pc = 0

For i = 1 To UBound(Fnames)
Set Pic = ActiveSheet.Pictures.Insert(Fnames(i))
Select Case (i - 1) Mod 4 + 1

Case 1
Pc = Pc + 1
If Pc >= 2 Then
ActiveSheet.HPageBreaks.Add R2
End If
With R
Pic.Left = .Left
Pic.Top = .Top
Pic.Width = 300
Pic.Height = 225
End With

Case 2
With R.Offset(0, 6) '一枚目に対する二枚目の相対位置
Pic.Left = .Left
Pic.Top = .Top
Pic.Width = 300
Pic.Height = 225
End With

Case 3
With R.Offset(18, 0)
Pic.Left = .Left
Pic.Top = .Top
Pic.Width = 300
Pic.Height = 225
End With

Case 4
With R.Offset(18, 6)
Pic.Left = .Left
Pic.Top = .Top
Pic.Width = 300
Pic.Height = 225
End With

'次ページの相対位置
Set R = R.Offset(39)
End Select
Next
Application.ScreenUpdating = True
End Sub


ここで、画像の上の位置(B5のセル位置の画像の場合、B4)に
元々の画像ファイル名を取得し、表記させたいのですが
調べた所、multiselect:=Trueで複数ファイルを選択するときに
画像名が図1、図2に変わっているようで、どうしていいかわかりません。

後、画像を300×225の「変倍」画像にしたいのですが
どのようにすれば可能でしょうか?

全くVBAの知識がなく、上のURLを参考に、単語を調べつつ書き換えている状態で、変数やらなんやらの指定・書き方等わかりません。
どなたかご教授願います。

質問者が選んだベストアンサー

  • 回答No.3

ベストアンサー率 41% (10/24)

縦横比を保持しないという設定に関しては
以下の部分に1行付け加えれば大丈夫です。
前回の修正とあわせて2行の追加ですね。
With R
Pic.ShapeRange.LockAspectRatio = msoFalse '←ここを追加
Pic.Left = .Left
Pic.Top = .Top
Pic.Width = 300
Pic.Height = 225
Pic.Name = FSO.GetBaseName(Fnames(i)) '←ここを追加
End With
これでどうでしょう?
お礼コメント
yn2008

お礼率 71% (5/7)

レスありがとうございます。
返信が遅くなりましてすみません。

色々ありがとうございます、理想通りに上手くいきました!
他、ファイル名の配置の方も無事解決できました。
これで、仕事がスムーズに進みます!

色々お世話になりました。
本当にありがとうございます!!!
投稿日時 - 2008-11-04 12:08:18
Be MORE 7・12 OK-チップでイイコトはじまる

その他の回答 (全2件)

  • 回答No.2

ベストアンサー率 62% (162/260)

正確ではないけど、参考にしてください。

Sub LoadPictures3()
  Dim Fnames As Variant
  Dim Fn   As Variant
  Dim i    As Integer
  Dim Pic   As Picture
  Dim R    As Range
  Dim R2   As Range
  Dim Pc   As Integer
  Dim wH   As Integer
  Dim wW   As Integer
  '
  wH = 1   '←高さの倍率を設定 (小数点、マイナス等は出来ません)
  wW = 2   '←幅の倍率を設定
  Fnames = Application.GetOpenFilename("図(*.jpg;*.gif),*.jpg;*.gif", MultiSelect:=True)
  If TypeName(Fnames) = "Boolean" Then Exit Sub
  
  Application.ScreenUpdating = False
  
  '一枚目の貼付け位置
  Set R = Range("B5")
  Set R2 = R.Offset(35 * wH)
  Pc = 0
  
  For i = 1 To UBound(Fnames)
    Set Pic = ActiveSheet.Pictures.Insert(Fnames(i))
    nm = Get_Name(Fnames(i))    '←ファイル名称取得
    Select Case (i - 1) Mod 4 + 1
      Case 1
        Pc = Pc + 1
        If Pc >= 2 Then
          ActiveSheet.HPageBreaks.Add R2
        End If
        With R
          Pic.Left = .Left
          Pic.Top = .Top
          Pic.Width = 300 * wW
          Pic.Height = 225 * wH
        End With
      Case 2
        With R.Offset(0, 6 * wW) '一枚目に対する二枚目の相対位置
          Pic.Left = .Left
          Pic.Top = .Top
          Pic.Width = 300 * wW
          Pic.Height = 225 * wH
        End With
      Case 3
        With R.Offset(18 * wH, 0)
          Pic.Left = .Left
          Pic.Top = .Top
          Pic.Width = 300 * wW
          Pic.Height = 225 * wH
        End With
      Case 4
        With R.Offset(18 * wH, 6 * wW)
          Pic.Left = .Left
          Pic.Top = .Top
          Pic.Width = 300 * wW
          Pic.Height = 225 * wH
        End With
        '次ページの相対位置
        Set R = R.Offset(39 * wH)
    End Select
    ActiveSheet.Pictures(i).Name = nm    '←ファイル名称設定
  Next
  Application.ScreenUpdating = True
End Sub
'ファイル名称取得
Function Get_Name(wNm As Variant) As String
  Dim wI   As Integer
  Dim wSt   As String
  Dim ExitFlg As Boolean
  wSt = wNm
  Do While ExitFlg = False
    wI = InStr(wSt, "\")
    If wI = 0 Then
      ExitFlg = True
    Else
      wSt = Mid(wSt, wI + 1)
    End If
  Loop
  Get_Name = wSt
End Function
お礼コメント
yn2008

お礼率 71% (5/7)

レスありがとうございます。
返信が遅くなりましてすみません。

このやり方だと、縦横比が一律になってしまいますよね。
複数の、色々なサイズの画像を強制的に同じサイズにしたかったんです。
説明の仕方が下手ですみません。

ファイル名取得については、このやり方だと場所の情報になるんですね。
色々なことができるのだなぁ、と勉強になりました。
今回は、lulさんの方法で解決しましたが、ありがとうございます!!
投稿日時 - 2008-11-04 12:06:04
  • 回答No.1

ベストアンサー率 41% (10/24)

名前に関してはプログラム始まってすぐの所で
Dim FSO
Set FSO = CreateObject("Scripting.FileSystemObject")
を宣言しておいて
以下の部分に1行付け加えれば大丈夫です。
With R
Pic.Left = .Left
Pic.Top = .Top
Pic.Width = 300
Pic.Height = 225
Pic.Name = FSO.GetBaseName(Fnames(i)) '←ここを追加
End With

Excel2000で試してみましたが、サイズに関してはちゃんと出来ているぽいですよ。
ピクセルとcmは違うので気をつけて下さいね。
お礼コメント
yn2008

お礼率 71% (5/7)

早々にありがとうございます!
試した所、無事名前を書き換えることができました!!
(まだ、上手くセルに配置できていませんが、
もう少し試行錯誤してみます)

画像サイズについては、説明不足で申し訳ありません、
縦横比が元画像と同じまま配置されてしまうので、
これを強制的に300×225にしたいのです。
(例えば、縦の画像も変形させて、横に配置したいということです)
検索はしてみたのですが、近い物がみつからなくて…。。。
投稿日時 - 2008-10-31 18:55:12
AIエージェント「あい」

こんにちは。AIエージェントの「あい」です。
あなたの悩みに、OKWAVE 3,500万件のQ&Aを分析して最適な回答をご提案します。

関連するQ&A
このやり方知ってる!同じこと困ったことある。経験を教えて!
このQ&Aにはまだコメントがありません。
あなたの思ったこと、知っていることをここにコメントしてみましょう。

その他の関連するQ&A、テーマをキーワードで探す

キーワードでQ&A、テーマを検索する

特集


より良い社会へ。感謝経済プロジェクト始動

ピックアップ

ページ先頭へ