Excel VBA質問箱 IV

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

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


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

6680 / 76734

←次へ　｜　前へ→


	【75653】画像の一括挿入

ちゃぷ - 14/6/5(木) 20:22 -


	引用なし

	パスワード

下記コードでExcel2000では使用可能でしたが、
2007では「このフォルダには画像がありません」
と表示されてしまいます。
どこを直したら良いか、教えて下さい。
宜しくお願いします。

Option Explicit

Public i As Long
Public strFolder As String
Public MaxWidth(8) As Long

Sub 画像の一括挿入()
　On Error GoTo Fin
　Dim objFS As Object
　Dim objFolder As Object
　Dim objFile As Object
　Dim blnExist As Boolean
　Dim FontSize
　Dim PicLen
　Application.EnableCancelKey = xlDisabled
　strFolder = ""
　FontSize = Array(6, 8, 9, 10, 11, 12, 14, 16, 18, 20, 22, 24)
　PicLen = Array(60, 90, 120, 150, 180, 210, 240, 270, 300, 330, 360, 390)
　Set objFS = CreateObject("Scripting.FileSystemObject")
　Set objFolder = CreateObject("Shell.Application").BrowseForFolder(0, "画像の入っているフォルダを選択してください", 0)
　If Not objFolder Is Nothing Then
　　strFolder = objFolder.Items.Item.Path
　End If
　If strFolder = "" Then Exit Sub
　If Right(strFolder, 1) <> "\" Then strFolder = strFolder & "\"
　Load UserForm1
　UserForm1.Label1.Caption = strFolder
　Application.ScreenUpdating = False
　For Each objFile In objFS.GetFolder(strFolder).Files
　　If 挿入可能(objFile) Then
　　　UserForm1.ListBox1.AddItem objFile.Name
　　　blnExist = True
　　End If
　Next
　For i = 0 To 11
　　UserForm1.ComboBox_Name.AddItem FontSize(i)
　Next i
　UserForm1.ComboBox_Name.ListIndex = 1
　For i = 0 To 11
　　UserForm1.ComboBox_PicLen.AddItem PicLen(i)
　Next i
　UserForm1.ComboBox_PicLen.ListIndex = 2
　Application.ScreenUpdating = True
　If blnExist Then
　　UserForm1.Show
　Else
　　MsgBox "このフォルダには画像がありません", vbInformation, "画像の挿入"
　End If
　Unload UserForm1
Fin:
　Application.EnableCancelKey = xlInterrupt
End Sub

Function 挿入可能(objFile) As Boolean
　On Error GoTo Err1
　ActiveSheet.Pictures.Insert(objFile).Delete
　挿入可能 = True
Err1:
End Function

3 hits

▼

【75653】画像の一括挿入 ちゃぷ 14/6/5(木) 20:22

≪