91

view

ご質問内でのコ－ドが、

”原寸に戻っていない”

という、ことが前提なら、
下記コ－ドをお試しください。

注意
Excel2007・ トリミング不可
ファイルサイズが膨らむ可能性
◇ Excel2010 ・トリミングは可能 ◇

３行目からの結合セルに対応

追加

☆ 1シ－ト、結合セル3個に対応
☆ ファイル選択で、3個以上選択した場合、次のシ－トに挿入
☆ シ－トが足りない場合は、終了

回答文字数を超えてしまいますので シ－トの自動作成はいたしません ｗ


' 修正版 第8弾 ｗｗ

Sub AddPicTest8()

Dim FName As Variant
Dim i As Long
Dim MyCell, Cnt
Dim R As Long, C As Integer
Dim ShtIdx As Integer, ShtCnt As Integer
Dim Sh As Shape
Dim Shell As Object, Folder As Object,Target As String
Dim StrDate As Variant, Fn As String
Dim L As Double, T As Double
Dim W As Double, H As Double

On Error GoTo Err

FName = Application.GetOpenFilename _
("jpg,*.jpg,jpeg,*.jpeg,bmp,*.bmp,gif,*.gif,png,*.png", , MultiSelect:=True)

If Not IsArray(FName) Then
MsgBox "取り消されました。", vbInformation
Exit Sub
End If

ShtIdx = ActiveSheet.Index
R = ActiveCell.Row: C = 1

Call BubbleSort_Str(FName, True, vbTextCompare)

Application.ScreenUpdating = False

For i = LBound(FName) To UBound(FName)

ShtCnt = ThisWorkbook.Worksheets.Count
If ShtCnt < ShtIdx Then
MsgBox "画像挿入のためのワ－クシ－トが足りません。", vbCritical
Exit Sub
End If

Worksheets(ShtIdx).Activate

Pth = Left(FName(i), InStrRev(FName(i), ""))
Fn = Mid(FName(i), InStrRev(FName(i), "") + 1)

Set Shell = CreateObject("Shell.Application")
Set Folder = Shell.Namespace(Pth)
Target = Dir(Pth & Fn)
' ↓ 撮影日取得：：Xp等の場合は、項目番号は "25" で ↓
StrDate = Folder.GetDetailsOf(Folder.ParseName(Target), 12)

With ActiveSheet.Cells(R, C).MergeArea
L = .Left: T = .Top: W = .Width: H = .Height 'Shapeの位置決め
End With

Set Sh = ActiveSheet.Shapes.AddShape(msoShapeRectangle, L, T, W, H)
Cnt = ActiveSheet.Shapes.Count

ActiveSheet.Shapes(Cnt).Name = R & "行_画像_" & Mid(FName(i), InStrRev(FName(i), "") + 1)

Range("B" & R).Value = ActiveSheet.Shapes(Cnt).Name
Range("B" & R).Font.ColorIndex = 2

With Sh
.Fill.UserPicture picturefile:=FName(i) 'Pictureの指定
.TextFrame.Characters.Text = StrDate '撮影日
.TextFrame.Characters.Font.Color = RGB(204, 0, 1) '文字色設定
.TextFrame.Characters.Font.Size = 16 '文字サイズ
.TextFrame.Characters.Font.Bold = True '太字
.TextFrame.VerticalAlignment = xlVAlignBottom '垂直方向の位置
.TextFrame.HorizontalAlignment = xlHAlignRight '水平方向の位置
End With

If R = 35 Then
ShtIdx = ShtIdx + 1
R = 3
Else
R = R + 16
End If

Set Sh = Nothing
Set MyCell = Nothing

Next i

Application.ScreenUpdating = True

MsgBox UBound(FName) & " 枚の画像を挿入しました", vbInformation

Exit Sub

Err:
MsgBox "エラー番号:" & Err.Number
MsgBox "エラー内容：" & Err.Description

End Sub

Private Sub BubbleSort_Str( _
ByRef Source As Variant, _
Optional ByVal SortAsc As Boolean = True, _
Optional ByVal Compare As VbCompareMethod = vbTextCompare)

If Not IsArray(Source) Then Exit Sub

Dim i As Long, j As Long
Dim vntTmp As Variant
For i = LBound(Source) To UBound(Source) - 1
For j = LBound(Source) To LBound(Source) + UBound(Source) - i - 1
If StrComp(Source(IIf(SortAsc, j, j + 1)), _
Source(IIf(SortAsc, j + 1, j)), Compare) = 1 Then
vntTmp = Source(j)
Source(j) = Source(j + 1)
Source(j + 1) = vntTmp
End If
Next j
Next i

End Sub



' 画像削除用1
' 例 A3セルが最上部の画像削除の場合は、B3セルを選択して実行
' 例 A19セルが最上部の画像削除の場合は、B19セルを選択して実行で

Sub ShpDel()
Dim Sh As Shape, R As Long

On Error GoTo Err

Application.ScreenUpdating = False

R = ActiveCell.Row

ActiveSheet.Shapes(ActiveCell.Value).Delete

Range("B" & R).ClearContents

Application.ScreenUpdating = True

Exit Sub

Err:

Application.ScreenUpdating = True
MsgBox "エラー番号:" & Err.Number
MsgBox "エラー内容：" & Err.Description

End Sub


' 画像削除用2
' シ－ト単位でアクテイブシ－トの全画像

Sub SheetShpAllDel()
Dim Sh As Shape

On Error GoTo Err

Application.ScreenUpdating = False

For Each Sh In ActiveSheet.Shapes
Sh.Delete
Next

Range("B1:B49").ClearContents

Application.ScreenUpdating = True

Exit Sub

Err:

Application.ScreenUpdating = True

MsgBox "エラー番号:" & Err.Number
MsgBox "エラー内容：" & Err.Description

End Sub