| |
▼ようちゃん さん：
>以前のレスを確認しました。
>確かに私の質問内容と一緒ですね。その原因が分かりました。
>
>私とその方は別人ですが、一緒にVBAを勉強している仲間でした。
>お互い先生から同じ課題を出されているのですが、
>コードがなかなかわからなかったところ、
>このサイトを見つけたため、別々に質問してしまったようです。
>不愉快な思いをさせてしまい、誠に申し訳ありませんでした。
>私が以前のレスを事前に確認しておりましたら、
>このようなことにはならなかったと反省しております。
>本当に申し訳ございません。。。
以下を試してみてください。
始めに、画像のある「Folderを指定」します。これまでのコードは
C:\ となってましたが、↓ではdesktopに変更してあります。
また、BrowseForFolder のツリーにFolder名だけでなく ファイル名
までも表示することがオプションを付け加えることにより、可能に
なります。
フォルダが選択されたら、Dir関数のLoopで フォルダ内のすべての
ファイルを検索し、そのうちファイル拡張子が <.jpeg><.jpg><.gif>
のファイルだけ シートのA列に「図の挿入」をします。
Excel2003までは 貼り付け先セルをアクティブにしておけば、その位置
に貼り付くのですけど、Excel2007 なのでそうなりません。ウィンドウ
の真ん中に貼り付けてから、 .Left .Top を指定しなおして目的のセルに
移動します。
貼り付けセルは最初 [A10]セルで、あとは 20行ずつ下に移動していき
ます。
貼り付ける画像の「高さ方向のサイズ」は、もし元の画像がセル15行
分より大きかったら、セル15行分に縮小しています。縦横比は固定です。
貼り付け作業は 独立したプロシージャで行ってます。
画像を貼り付けたら、そのセルのF列の位置に 貼り付けた画像名 を
書き込みます（J列だと、離れていたので）。
...などなど、いろいろ、勝手に仕様を変更しています。
コードを読んで、そちらの仕様に変更してください。
Sub PasteDirImage()
'フォルダ選択
Dim oFolder As Object
Const BIF_RETURNNONLYFSDIRS = &H1 'ディレクトリのみ選択可
Const BIF_EDITBOX = &H10 'アイテム名入力用のEdit_boxを表示
Const BIF_BROWSEINCLUDEFILES = &H4000 'ファイルも表示して選択できる
Dim hWnd As Long
Dim sPath As String
hWnd = Application.hWnd
Set oFolder = CreateObject("Shell.Application") _
.BrowseForFolder _
(hWnd, _
"フォルダを選択して下さい", _
BIF_RETURNNONLYFSDIRS Or BIF_EDITBOX, _
CreateObject("WScript.Shell").Specialfolders("desktop"))
If (oFolder Is Nothing) Then Exit Sub
sPath = oFolder.Self.Path & "\"
' Dirで指定フォルダ内をLoop 画像をA列に貼り付け
Dim fileName As String
Dim c As Range
Dim pos As Integer
Dim szoom
szoom = ActiveWindow.Zoom
ActiveWindow.Zoom = 100
'最初の画像貼り付けセル
Set c = [A10]
fileName = Dir$(sPath & "*.*")
Do Until Len(fileName) = 0
' ファイル拡張子の判別
pos = InStrRev(fileName, ".")
If pos > 0 Then
Select Case LCase$(Mid$(fileName, pos))
Case ".jpeg", ".jpg", ".gif"
c.Select
'画像貼り付け(図の挿入)
PasteImage sPath & fileName, c.Resize(15)
Set c = c.Offset(20) '次の画像貼り付け位置
End Select
End If
fileName = Dir()
Loop
ActiveWindow.Zoom = szoom
MsgBox "画像の読込みが終了しました"
End Sub
'// 画像貼り付け(図の挿入) F列に 画像名
Private Sub PasteImage(fileName$, c As Range)
Dim ratio As Double
With ActiveSheet.Pictures.Insert(fileName).ShapeRange
.Left = c.Left
.Top = c.Top
.LockAspectRatio = True
' 画像が大きい場合、画像サイズをセル高さに合わせる
ratio = c.Height / .Height
If ratio < 1# Then .Height = .Height * ratio
End With
c.Range("F1").Value = fileName 'または Dir$(filename)
End Sub
|
|
kanabun
- 12/2/10(金) 21:01 -
