Excel写真帳の写真を挿入マクロを教えて下さい。

質問

Excelで工事写真帳での写真枠のダブルクリックで写真挿入の
マクロを教えて下さい。

使用パソコン
第１パソコン・Windows7・Excel2013
第２パソコン・WindowsXp・Excel2003

現在Excel2013をメインに使用しています。
今までExcel2003でExcelでの工事写真帳と資料用の写真帳をマクロで
写真挿入枠をセルの結合で作成して、ダブルクリックで写真データ保存の
フォルダを開いて写真の挿入をしていました。

Excel2013で使用すると
データ（工事写真帳と資料用の写真帳）を別のパソコンへ移動したり
データを第三者への提出したり、写真データの移動／削除すると
下記のような状態（コメント）になります。

リンクされたイメージを表示出来ません。ファイルが移動または削除されたか、
名前が変更された可能性があります。リンクに正しいファイル名と場所が
指定されていることを確認して下さい。

状況は、たぶんリンク貼り付けになってしまう仕様に新Excelはなっている。

Excel 2010 で Pictures.Insert メソッドを使用して図をワークシートに
挿入すると図がリンク オブジェクトとして挿入される
http://support.microsoft.com/kb/2396509/ja
だと思っててます。

リンク回避もしくはマクロをどの様に変更したら良いのでしょうか。
使用しているマクロは下記です。（Excel2003で使用していたマクロ）
よろしくご教授をお願いします。。

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim fname As String
Dim pos As Integer

If Target.Column <> 2 Then Exit Sub
If Target.Cells.count = 1 Then Exit Sub

Cancel = True
fname = Application.GetOpenFilename()
If fname = "False" Then Exit Sub
pos = InStrRev(fname, ".")
If pos > 0 Then
Select Case LCase(Mid(fname, pos + 1))
Case "jpeg"
Case "jpg"
Case "gif"
Case Else
Exit Sub
End Select
Else
Exit Sub
End If

With ActiveSheet.Pictures.Insert(fname)
.ShapeRange.LockAspectRatio = msoTrue
.Height = Target.Height
If .Width > Target.Width Then
.Width = Target.Width
End If
.Top = Target.Top + (Target.Height - .Height) / 2
.Left = Target.Left + (Target.Width - .Width) / 2
End With
End Sub

回答No.4

masatsan · ベストアンサー

幅を合わせて、立てはその比率で拡大縮小ということですね。
うまく行くかわかりませんが

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim fname As String
Dim pos As Integer

If Target.Column <> 2 Then Exit Sub
If Target.Cells.Count = 1 Then Exit Sub

Cancel = True
fname = Application.GetOpenFilename()
If fname = "False" Then Exit Sub
pos = InStrRev(fname, ".")
If pos > 0 Then
Select Case LCase(Mid(fname, pos + 1))
Case "jpeg"
Case "jpg"
Case "gif"
Case Else
Exit Sub
End Select
Else
Exit Sub
End If

If Selection.Width > Target.Width Then
w = Target.Width
Else
w = Selection.Width
End If
h = Selection.Height

Set P = LoadPicture(fname)
w = P.Width * 0.0378
h = P.Height * 0.0378

Set myshape = ActiveSheet.Shapes.AddPicture(Filename:=fname, _
LinkToFile:=True, SaveWithDocument:=True, Left:=Target.Left, _
Top:=Target.Top, Width:=w, Height:=h)

With myshape
.LockAspectRatio = msoTrue
.Width = Selection.Width
End With

End Sub

お礼

皆様有り難うございました。

masatsan 様のマクロを使わせて頂きます。
使い慣れたマクロを使用したく思います。

補足

確認報告です。

マスターデータ形式、Excel2003形式（　 .xls　）を、Excel2013での作業。

作業Ａ：
写真データを挿入後保存して画像データを削除し、保存データを
別のフォルダへ移動してファイルを開くという手順で確かめました。
写真データ：2816X2112 ／ 1600X1200 ／ 1920X1080 ／ 1920X1200

１．
Excel2003形式をExcel2013で開き、このマクロを記録して
Excel2003（　.xls　）形式で保存。
再度Excel2013で立ち上げ画像挿入後 Excel2003形式で保存。

作業Ａをしましたが問題無く画像保存は出来ていました。
●画像の比率も問題無く収まっていました。

２．
Excel2003形式をExcel2013で開き、このマクロを記録して
Excel2013　マクロ有効ブック（　.xlsm　）形式で保存。
再度Excel2013で立ち上げ画像挿入後 Excel2013マクロ有効ブック形式で保存。

作業Ａをしましたが問題無く画像保存は出来ていました。
●画像の比率も問題無く収まっていました。

masatsan 様、有り難うございました。
上記報告させて頂きます。

もう少し使いこんでみますね。

回答No.5

noname#176594

最近この質問が多いように思います。

わたくしも先月Excel2013を使用してこの現象でマクロを変更しました。

ご紹介のマクロは２通りあります。
Excel2013でのリンク回避出来ているマクロです。

●マクロ１：　（現在使用のマクロです。）
写真挿入結合セルの横幅を基準にサイズ調整されます。元写真サイズ比率を保つ。

Excel2013の場合
写真挿入結合セルをクリックで画像の挿入ウインドウが開きます。
（もう一度同一セルをクリックする場合、一旦他のセルクリック後再クリック）
ファイルから／Office.com クリップアート／Bing イメージ検索Webを検索します
の３つから選択してから挿入データ場所選択後、写真選択します。
Excel2003 の場合
図の挿入ウインドウが開きます。

●マクロ２：
写真挿入結合セルをダブルクリックで画像の挿入ウインドウが開きます。
写真挿入結合セルの縦横幅に縮小して挿入されます。
結合セルのサイズは、きっちり元の写真縦横比率に合うよう作成必要。
横長の写真の場合は多少縦方向に伸びますが元写真の比率が一定の場合
素早く写真挿入出来ます。

Excel2013・Excel2003。
写真挿入結合セルをダブルクリックで画像の選択ウインドウが開きます。

マクロ説明：
写真挿入結合セルの指定

●マクロ１：例
2 And Target.Rows.Count = 13 Then
の場合、ご使用写真挿入結合セルの設定は
2 は、結合セル（写真挿入枠）の列数。
13 は、結合セル（写真挿入枠）の行数。
上記で結合セルを指定します。

●マクロ２：例
全てのセルダブルクリックで画像の挿入ウインドウが開きます。
Sheet上に写真挿入結合セルのサイズが複数ある場合など便利です。
（結合セルのサイズは、きっちり元の写真縦横比率に合うよう作成必要。）

●マクロ１：
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim dlgAnswer As Boolean, x As Object, MyWidth As Single, MyHeight As Single
If Target.Columns.Count = 6 And Target.Rows.Count = 18 Then

Application.ScreenUpdating = False
MyWidth = Target.Width
MyHeight = Target.Height

dlgAnswer = Application.Dialogs(xlDialogInsertPicture).Show
For Each x In ActiveSheet.Shapes
With x
If .Width > MyWidth Then
.LockAspectRatio = msoTrue
.Width = MyWidth
.Line.ForeColor.SchemeColor = 64
.Line.Visible = msoTrue
End If
End With
Next
Application.ScreenUpdating = True

End If
End Sub

◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆
◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆

●マクロ２：
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Option Explicit

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean)
Dim myF As Variant
Dim mySp As Object
Dim myAD1 As String
Dim myAD2 As String
Dim myHH As Double
Dim myWW As Double
Dim myHH2 As Double
Dim myWW2 As Double

Cancel = True

'===============画像選択
myF = Application.GetOpenFilename _
("jpg bmp tif png gif,*.jpg;*.bmp;*.tif;*.png;*.gif", , "画像の選択", , False)
If myF = False Then
MsgBox "画像を選択してください(終了)"
Exit Sub
End If
'===============画像の掃除
For Each mySp In ActiveSheet.Shapes
myAD1 = mySp.TopLeftCell.MergeArea.Address
myAD2 = Target.Address
If myAD1 = myAD2 Then mySp.Delete
Next
'===============画像の貼り付け
Set mySp = ActiveSheet.Shapes.AddPicture(Filename:=myF, LinkToFile:=False, _
SaveWithDocument:=True, Left:=Target.Left, Top:=Target.Top, _
Width:=0, Height:=0) '★　とりあえず　縦横０で。
mySp.ScaleHeight 1, msoTrue '★元のサイズに戻す
mySp.ScaleWidth 1, msoTrue '★元のサイズに戻す
'===============タテヨコの縮尺を保持
If mySp.Width > Target.Width Then mySp.Width = Target.Width
If mySp.Height > Target.Height Then mySp.Height = Target.Height
'===============中央へ調整
myHH2 = (Target.Height / 2) - (mySp.Height / 2)
myWW2 = (Target.Width / 2) - (mySp.Width / 2)
mySp.Top = Target.Top + myHH2
mySp.Left = Target.Left + myWW2

Set mySp = Nothing

End Sub

◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆
◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆◆

補足

確認報告です。

マスターデータ形式、Excel2003形式（　 .xls　）を、Excel2013での作業。

作業Ａ：
写真データを挿入後保存して画像データを削除し、保存データを
別のフォルダへ移動してファイルを開くという手順で確かめました。
写真データ：2816X2112 ／ 1600X1200 ／ 1920X1080 ／ 1920X1200

◆マクロ１の確認

１．
Excel2003形式をExcel2013で開き、このマクロを記録して
Excel2003（　.xls　）形式で保存。
再度Excel2013で立ち上げ画像挿入後 Excel2003形式で保存。

作業Ａをしましたが問題無く画像保存は出来ていました。
●画像の比率も問題無く収まっていました。

２．
Excel2003形式をExcel2013で開き、このマクロを記録して
Excel2013　マクロ有効ブック（　.xlsm　）形式で保存。
再度Excel2013で立ち上げ画像挿入後 Excel2013マクロ有効ブック形式で保存。

作業Ａをしましたが問題無く画像保存は出来ていました。
●画像の比率も問題無く収まっていました。

◆マクロ２の確認

１．
Excel2003形式をExcel2013で開き、このマクロを記録して
Excel2003（　.xls　）形式で保存。
再度Excel2013で立ち上げ画像挿入後 Excel2003形式で保存。

作業Ａをしましたが問題無く画像保存は出来ていました。
■画像の比率は横長の場合写真枠いっぱいになり少し縦長になった。
写真挿入結合セルを使用する写真データの比率を固定すれば問題なしです。
（回答の記載通りでした。）。

２．
Excel2003形式をExcel2013で開き、このマクロを記録して
Excel2013　マクロ有効ブック（　.xlsm　）形式で保存。
再度Excel2013で立ち上げ画像挿入後 Excel2013マクロ有効ブック形式で保存。

作業Ａをしましたが問題無く画像保存は出来ていました。
■画像の比率は横長の場合写真枠いっぱいになり少し縦長になった。
写真挿入結合セルを使用する写真データの比率を固定すれば問題なしです。
（回答の記載通りでした。）。

xp9500 様　有り難うございました。　
上記報告させて頂きます。

マクロ１はExcel2013の機能を有効活用出来そうです。

回答No.3

masatsan

#1,2です。
２０１０を持っていないのでどうか分かりませんが
以下でどうでしょうか？

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim fname As String
Dim pos As Integer

If Target.Column <> 2 Then Exit Sub
If Target.Cells.Count = 1 Then Exit Sub

Cancel = True
fname = Application.GetOpenFilename()
If fname = "False" Then Exit Sub
pos = InStrRev(fname, ".")
If pos > 0 Then
Select Case LCase(Mid(fname, pos + 1))
Case "jpeg"
Case "jpg"
Case "gif"
Case Else
Exit Sub
End Select
Else
Exit Sub
End If

If Selection.Width > Target.Width Then
w = Target.Width
Else
w = Selection.Width
End If
h = Selection.Height

Set myshape = ActiveSheet.Shapes.AddPicture(Filename:=fname, _
LinkToFile:=True, SaveWithDocument:=True, Left:=Target.Left + (Target.Width - w) / 2, _
Top:=Target.Top + (Target.Height - h) / 2, Width:=w, Height:=h)

With myshape
.LockAspectRatio = msoTrue
.Height = Selection.Height
End With

End Sub

補足

masatsan 様、有り難うございました。

Excel2013で確認しました。
問題無く写真の挿入出来ました。
ファイル移動（同一パソコン内ですが）と挿入データ削除しても
問題はありませんでした。

もう一つ教えて頂きたいのですが、
デジカメで写真データ、２８１６Ｘ２１１２、サイズを基本としています。
プリント時はＬ版サイズに合うよう写真挿入枠を作成しています。

2 Then Exit Subの２（Ｂ列）に設定しています。

１９２０Ｘ１０８０などの横長の写真の場合は縦長になってしまいます。
横長用にSheetを再作成すればすむ事ですが、
マクロで比率調整しての挿入のマクロは出来るのでしようか。
お返事頂ければ助かります。
よろしくお願いします。

回答No.2

masatsan

＃１です。
ごめんなさい。理由は分かっていた上に同じＵＲＬを貼ってしまいました。無視してください。
本当にごめんなさい。

回答No.1

masatsan

Pictures.InsertはＥＸＣＥＬ２０１０以降リンクで貼られるとのこと。

Shapes.AddPicture

を使えとなっています。
http://support.microsoft.com/kb/2396509/ja