みんなの「教えて(疑問・質問)」にみんなで「答える」Q&Aコミュニティ

こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

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

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

使用パソコン
第1パソコン・Windows7・Excel2013
第2パソコン・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

投稿日時 - 2013-03-28 14:30:47

QNo.8015743

困ってます

質問者が選んだベストアンサー

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

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

投稿日時 - 2013-03-29 05:55:14

補足

確認報告です。

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

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

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

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


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

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


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

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

投稿日時 - 2013-03-29 17:39:25

お礼

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

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

投稿日時 - 2013-03-29 19:34:55

このQ&Aは役に立ちましたか?

5人が「このQ&Aが役に立った」と投票しています

回答(5)

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

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

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


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

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

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

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

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

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

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




●マクロ1:
------------------------------
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





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



●マクロ2:
------------------------------
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) '★ とりあえず 縦横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





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

投稿日時 - 2013-03-29 14:12:45

補足

確認報告です。

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

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


◆マクロ1の確認

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

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


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

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




◆マクロ2の確認

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

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


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

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



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

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

投稿日時 - 2013-03-29 19:29:21

ANo.3

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

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

投稿日時 - 2013-03-28 21:23:31

補足

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

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

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

2 Then Exit Subの2(B列)に設定しています。

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

投稿日時 - 2013-03-28 22:30:40

ANo.2

#1です。
ごめんなさい。理由は分かっていた上に同じURLを貼ってしまいました。無視してください。
本当にごめんなさい。

投稿日時 - 2013-03-28 16:38:59

ANo.1

Pictures.InsertはEXCEL2010以降リンクで貼られるとのこと。

Shapes.AddPicture

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

投稿日時 - 2013-03-28 16:20:38

あなたにオススメの質問