- ベストアンサー
Excel写真帳の写真を挿入マクロを教えて下さい
masatsanの回答
- masatsan
- ベストアンサー率15% (179/1159)
Pictures.InsertはＥＸＣＥＬ２０１０以降リンクで貼られるとのこと。 Shapes.AddPicture を使えとなっています。 http://support.microsoft.com/kb/2396509/ja
関連するQ&A
- Excel2010でのマクロによる画像貼付について
エクセル2010で下記のマクロを実行し、一旦保存して再度開くと、 「リンクされたイメージを表示できません。ファイルが移動または削除されたか、名前が変更された可能性があります。リンクに正しいファイル名と場所が指定されていることを確認してください。」 と表示されます。 検索したところ、Pictures.Insertでなく、2010では、Shapes.Addを使用するとの事ですが、 マクロに詳しく無いため、どこを修正したらいいのかわかりません。 大量の写真貼り付けがあるので、教えて頂けると大変助かります。 どうぞよろしくお願いいたします。 Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean) '===============起動の合図 If ActiveCell.FormulaR1C1 = "画像" Then Cancel = True '===============画像選択 SSS = Application.GetOpenFilename _ ("jpg bmp tif png gif,*.jpg;*.bmp;*.tif;*.png;*.gif", , "画像の選択", , False) If SSS = False Then MsgBox "画像を選択してください(終了)" Exit Sub End If '===============画像の貼り付け Set CCC = ActiveSheet.Pictures.Insert(SSS) '===============タテヨコの縮尺を保持 HH = Target.Height / CCC.Height WW = Target.Width / CCC.Width If HH > WW Then CCC.Height = CCC.Height * 0.99 CCC.Width = Target.Width * 0.99 Else CCC.Height = Target.Height * 0.99 CCC.Width = CCC.Width * 0.99 End If '===============中央へ調整 HH2 = (Target.Height / 2) - (CCC.Height / 2) WW2 = (Target.Width / 2) - (CCC.Width / 2) CCC.Top = Target.Top + HH2 CCC.Left = Target.Left + WW2 Set CCC = Nothing End If End Sub
- ベストアンサー
- オフィス系ソフト
- エクセルに写真を挿入するVBA
エクセルで写真集を作るためのVBAですが、以下のVBAでは画像がリンク貼り付けになってしまいます。どうしたらエクセルファイルに画像を貼りこみで保存できるのでしょうか？ よろしくお願いいたします。 やりたいことは、まずダブルクリックでダイアログボックスを表示させ、挿入したい写真を選択、写真がセルに合わせた大きさに縮小、セルの中央に写真を配置。以上です。 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, _ Cancel As Boolean) Dim PicFile As Variant Dim rX As Double, rY As Double '［ファイルを開く］ダイアログボックスを表示 PicFile = Application.GetOpenFilename( _ "画像ファイル,*.jpg;*.jpeg;*.gif;*.tif;*.png;*.bmp") If VarType(PicFile) = vbBoolean Then Cancel = True: Exit Sub Application.ScreenUpdating = False '画像を挿入 With ActiveSheet.Pictures.Insert(PicFile) rX = Target.Width / .Width rY = Target.Height / .Height If rX > rY Then .Height = .Height * rY Else .Width = .Width * rX End If 'セルの中央（横方向/縦方向の中央）に配置 .Left = Target.Left + (Target.Width - .Width) / 2 .Top = Target.Top + (Target.Height - .Height) / 2 End With Application.ScreenUpdating = True Cancel = True End Sub
- 締切済み
- その他MS Office製品
- エクセル2007でマクロを使った写真挿入がうまくいきません。
エクセル2007でマクロを使った写真挿入がうまくいきません。 エクセル2003で使っていたひな形をもらったのですが2007では結合したセルから ずれてしまいます。 どうすれば位置の修正をできますか？ また、結合した大きなセルの中にフォームボタンを付けいるのですが 2003では写真が挿入されるとボタンは隠れてしまっていたのですが、 2007では挿入した写真に重ねって写真が見ずらいです。 隠すことはできるのでしょうか？ なにぶん初心者なのでお願いします。 Sub Pic_in() ' マクロ記録日 : 2003/7/1 kome fname = Application.GetOpenFilename ActiveSheet.Pictures.Insert(fname).Select Selection.ShapeRange.LockAspectRatio = msoFalse Selection.ShapeRange.Height = 247.5 Selection.ShapeRange.Width = 350 End Sub
- ベストアンサー
- オフィス系ソフト
- マクロで画像挿入の質問です
マクロ 初心者です。 ワークシート指定して、ダブルクリック等を使っての画像選択、貼り付け＆セルの大きさに合わせる）ことはできるのですが、 ダブルクリック等ではなく、手動でマクロを実行して指定のセル（B37）に貼り付けることはできるでしょうか？（セルの大きさに画像が変換するのは生かしたまま） Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)を sub マクロ名（）にして、Moduleに貼り付けて実行したら myAD2 = Target.Address 上記場所でエラーになってしまいます。 どのように変更したら、できるでしょうか？または、できる手段はないのでしょうか？ ご教授お願いします。 使用ベースマクロは以下です。 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) 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.Pictures.Insert(myF) '===============タテヨコの縮尺を保持 myHH = Target.Height / mySP.Height myWW = Target.Width / mySP.Width If myHH > myWW Then mySP.Height = mySP.Height * myWW mySP.Width = Target.Width Else mySP.Height = Target.Height mySP.Width = mySP.Width * myHH End If '===============中央へ調整 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
- ベストアンサー
- Visual Basic
- Excel2010マクロ／挿入した画像がぼける
過去に2度、Excel2003を利用して工事写真帳を作成する方法を質問させていただきました。最近、社内でExcel2010を使用している人が多くなり、修正した写真帳でも不具合が発生するようになり、その原因を調べているのですが同じ症例がなかなか見当たりません。そこで今回もまたお知恵を拝借したいと思い投稿しました。 【仕様】工事写真帳は複数シート構成、1シートはA4サイズで縦に3枚の画像が読み込めます。画像の右側には摘要欄があります。画像を読み込む位置をダブルクリックするとセルのサイズ（写真サイズにしてあります）を取得して画像サイズを変更して格納します。 【問題点】一度保存したファイルを開くと画像がぼける。図の書式設定の[サイズ]を確認すると、サイズと角度の高さ=9.59cm、幅=13.69cm（読み込むセルのサイズ）、原型のサイズの高さ=0.38cm、幅=0.42cmとなっています。元の画像サイズは640×480なので、マクロを実行中、どこかのタイミングで画像の一部をトリミングし、縦横サイズを小さくした画像をセルサイズにまで拡大していることが原因だということまではわかりました。ただ、すべてのシートがこの状態なわけではなく、正常に表示されているシートもあります。この場合も画像のサイズと角度の高さ=9.59cm、幅=13.69cm（読み込むセルのサイズ）、原型のサイズの高さ=9.59cm、幅=13.69cmと元の画像より小さくなっています。 コードは次の通りです。どこに問題があるか、ぜひアドバイスをお願いします。 Private Sub Workbook_SheetBeforeDoubleClick(ByVal sh As Object, ByVal Target As Range, Cancel As Boolean) Dim pict As Shape Dim fname With Target If .Column <> 3 Then Exit Sub '3列目でなかったら終了 fname = Application.GetOpenFilename _ ("画像ファイル,*.gif;*.jpg;*.bmp", 1, "画像ファイルを指定して下さい") '画像読込 If fname = False Then Exit Sub Set pict = sh.Shapes.AddPicture(Filename:=fname, linktofile:=True, _ SaveWithDocument:=True, Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height) pict.LockAspectRatio = False '指定された図形のサイズ比率を保持しない pict.Placement = xlMove 'オブジェクトをセルと共に移動する .Offset(, 3).Select '摘要欄（右へ3）へ移動 End With End Sub
- 締切済み
- オフィス系ソフト
- Excel２００３で動いたVisualが２００７では？
Excel２００３で作った下記のVisual Basicが２００７では、最初にクリックしたところには行かず いつも同じ位置に挿入されます。 出来ればセルF1の位置に挿入したいのですが Sub macro1() Dim Fname As String Dim FLT As String Dim Sheetmei As String FLT = "JPEGファイル(*.jpg),*.jpg" Fname = Application.GetOpenFilename(FLT, 2, "開く", True) If Fname = "False" Then Exit Sub End If Sheetmei = Worksheets(1).Name ActiveSheet.Pictures.Insert(Fname).Select Call Jpeg_size_adjust End Sub サブで下記も有ります Sub Jpeg_size_adjust() Selection.ShapeRange.LockAspectRatio = msoFalse Selection.ShapeRange.Height = 270.75 Selection.ShapeRange.Width = 360
- 締切済み
- オフィス系ソフト
- エクセル マクロ
エクセルのある特定のセルをダブルクリックすると 画像ファイルを参照しにいき 貼りつけたい画像ファイル選ぶと そのセルの大きさに合わせて 画像ファイルがそのセルに 貼りつくというマクロが以下の通りなんですが Excel2003からExcel2007へ変更すると 画像ファイルの貼りつく位置がダブルクリックしたセルではない所に 貼りつくようになりました 参照や大きさなどはちゃんと機能しているようです どこを変更すればよいでしょうか？ Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Intersect(Target, Range('特定のセル)) Is Nothing Then Exit Sub Cancel = True Dim myPic Dim myRange As Range Dim rX As Double, rY As Double myPic = Application.GetOpenFilename("画像ファイル,*.jpg;*.jpeg;*.gif;*.tif") If VarType(myPic) = vbBoolean Then Exit Sub Set myRange = Target Application.ScreenUpdating = False With ActiveSheet.Pictures.Insert(myPic).ShapeRange rX = myRange.Width / .Width rY = myRange.Height / .Height If rX > rY Then .Height = .Height * rY Else .Width = .Width * rX End If .Left = .Left + (myRange.Width - .Width) / 2 .Top = .Top + (myRange.Height - .Height) / 2 End With Application.ScreenUpdating = True Cancel = True End Sub
- ベストアンサー
- オフィス系ソフト
- エクセル 写真貼り付け マクロ
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean) 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.Pictures.Insert(myF) '===============タテヨコの縮尺を保持 myHH = Target.Height / mySP.Height myWW = Target.Width / mySP.Width If myHH > myWW Then mySP.Height = mySP.Height * myWW mySP.Width = Target.Width Else mySP.Height = Target.Height mySP.Width = mySP.Width * myHH End If '===============中央へ調整 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 ネットでこのマクロを見つけて応用したいのですが 教えてください セルをダブルクリックすると画像が選べて貼り付けできるのですが 全部のセルに反応してしまいます セルの範囲指定したいのですがどうすればいいでしょうか？ (1)セル結合でＡ１：Ｄ７範囲だけにこのマクロを入れておきたい場合 (2)セル結合でＡ１：Ｄ７とＸ１：ＡＡ４までとか複数選択したい場合 宜しくお願いします
- ベストアンサー
- Excel（エクセル）
- 【急】Excelで写真張り付けマクロを書き換えたい
下記マクロを拾い利用しようと思っているのですが、 以下の点を急ぎ修正しないと使えません。 修正方法などが分からないので、ご教示ください。 要件： ・セルをクリックして写真選択して張り付け、 ・縦横比を変えずに、クリックした結合セルサイズ内に収める。 ・写真は縦横混在に対応 ・写真をセンターに配置する。 ・セルのサイズは変動する。 現状の問題点： ・縦向きの写真を挿入した際にセルの上下から画像がはみ出してしまう。 以下コードーーーーーーーーーーーーーーー Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean) Cancel = True '画像選択コマンド myF = Application.GetOpenFilename _ ("jpg bmp tif png gif,*.jpg;*.bmp;*.tif;*.png;*.gif", , "画像の選択", , False) If myF = False Then MsgBox "編集する場合はF2を押下してください。" 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 * 0.99 If mySp.Height > Target.Height Then mySp.Height = Target.Height * 0.99 'センター中心に配置 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 以上ご協力の程宜しくお願い申し上げます。
- ベストアンサー
- Excel（エクセル）
- VBAの写真貼り付けコードについて教えてください。
写真をダブルクリックで簡単に貼り付けられるVBAのプログラムを友人に貰ったのですが、 追加で図の外枠に黒の2.5ptくらいの線を縁取る文を追加しようと、マクロで記録したプログラムを 入れてみたのですが上手く動作しません。 コードが --------------------------------------------------------------------------------- Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean) Cancel = True If Target.MergeCells = False Then Exit Sub '===============画像選択 myF = Application.GetOpenFilename _ ("jpg bmp tif png gif,*.jpg;*.bmp;*.tif;*.png;*.gif", , "画像の選択", , False) If myF = False Then 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.Pictures.Insert(myF) '===============タテヨコの縮尺を保持 myHH = Target.Height / mySP.Height myWW = Target.Width / mySP.Width If myHH > myWW Then mySP.Height = mySP.Height * myWW mySP.Width = Target.Width Else mySP.Height = Target.Height mySP.Width = mySP.Width * myHH End If '===============中央へ調整 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 ------------------------------------------------------------------------- お願いいたします。
- 締切済み
- Visual Basic