| |
If 挿入可能(objFile)をIf 挿入可能(objFile.Path)
にすることで、画像挿入はできるようになりましたが、
指定セルに画像を各々貼り付けする事ができません。
UserForm1に記載されているコードで画像挿入位置を
変えればよいかと思いますが、どこを変えたらよいか
わかりません。
いろいろ調べると下記コードに行き着きましたが、
繋げ方がわかりませんので、教えて下さい。
選択セルを左上端として画像を挿入
With ActiveSheet.Pictures.Insert(Filename:=myFileName)
.Top = ActiveCell.Top
.Left = ActiveCell.Left
End With
UserForm1
Private Sub CommandButton_OK_Click()
Dim j As Long
Dim EndColumn As Byte
Dim MaxHeight As Long
Dim MaximumWidth As Long
For i = 0 To Me.ListBox1.ListCount - 1
If Me.ListBox1.Selected(i) = True Then GoTo Line1
Next i
MsgBox "選択されていません", vbExclamation
Exit Sub
Line1:
MsgBox "新しいブックに画像を挿入します"
Workbooks.Add
Application.ScreenUpdating = False
Range("A1").Select
If Me.OptionButton_C1.Value Then
EndColumn = 1
ElseIf Me.OptionButton_C2.Value Then
EndColumn = 3
ElseIf Me.OptionButton_C3.Value Then
EndColumn = 5
ElseIf Me.OptionButton_C4.Value Then
EndColumn = 7
ElseIf Me.OptionButton_C5.Value Then
EndColumn = 9
ElseIf Me.OptionButton_C6.Value Then
EndColumn = 11
ElseIf Me.OptionButton_C7.Value Then
EndColumn = 13
Else
EndColumn = 15
End If
For i = 0 To Me.ListBox1.ListCount - 1
If Me.ListBox1.Selected(i) = False Then GoTo Line2
If Me.CheckBox_Name.Value Then
ActiveCell.Value = Me.ListBox1.List(i)
ActiveCell.EntireRow.AutoFit
ActiveCell.Offset(1, 0).Select
End If
ActiveSheet.Pictures.Insert(strFolder & Me.ListBox1.List(i)).Select
サイズ調整
If Selection.Width > MaxWidth((ActiveCell.Column - 1) / 2) Then MaxWidth((ActiveCell.Column - 1) / 2) = Selection.Width
If Selection.Height > MaxHeight Then MaxHeight = Selection.Height
If ActiveCell.Column = EndColumn Then
ActiveCell.EntireRow.RowHeight = MaxHeight
MaxHeight = 0
If Me.OptionButton_RNone.Value Then
Cells(ActiveCell.Row + 1, 1).Select
ElseIf Me.OptionButton_R1.Value Then
Cells(ActiveCell.Row + 2, 1).Select
ElseIf Me.OptionButton_R2.Value Then
Cells(ActiveCell.Row + 3, 1).Select
Else
Cells(ActiveCell.Row + 4, 1).Select
End If
Else
ActiveCell.Offset(0, 2).Select
If Me.CheckBox_Name.Value Then ActiveCell.Offset(-1, 0).Select
End If
Line2:
Next i
If Me.CheckBox_Name.Value Then
ActiveCell.Offset(1, 0).EntireRow.RowHeight = MaxHeight
Else
ActiveCell.EntireRow.RowHeight = MaxHeight
End If
列幅調整 EndColumn
If Me.CheckBox_Name.Value Then Cells.Font.Size = Me.ComboBox_Name.Value
Unload Me
Application.ScreenUpdating = True
End Sub
▼ちゃぷ さん：
> 下記コードで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
|
|
インフェルエンス
- 14/6/9(月) 15:11 -
kanabun
- 14/6/9(月) 14:38 -
γ
- 14/6/8(日) 0:09 -
ちゃぷ
- 14/6/7(土) 18:19 -
