[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『イメージ画像?で張り付けていた昔の写真張り付けのマクロの変更』(すが)
すごく昔にエクセルへの写真張り付けのマクロを作っていただきました。
久々使ったところ、昔と違って写真のフォルダを動かすと、表示できません
「リンクされたイメージの表示ができません」のメッセージが出てしまいます。
今はShapes.AddPictureメソッドを使うということらしいですが、どこを直せばいいのでしょうか
Sub Sump_Phot()
'画像取込み
Dim ico As Long, stc As Variant, selnm As Variant
Const z1 As Single = 255 'サイズ指定
'ChDir "D:\Other"
selnm = Application.GetOpenFilename(Title:="Ctrl、複数選択OK", _
MultiSelect:=True) If TypeName(selnm) = "Boolean" Then Exit Sub ico = 10 '最上位の位置 Application.ScreenUpdating = False On Error Resume Next With ActiveSheet 'Sheet指定 For Each stc In selnm With .Shapes(.Pictures.Insert(stc).Name) If Err.Number = 0 Then .Name = Dir(stc, vbNormal) '名前付け .LockAspectRatio = msoTrue '縦横比保持 .Left = 0 '左位置指定 .Top = ico '上位置指定 .Width = z1 '横型 If .Height > .Width Then .Height = z1 '縦型 ico = ico + z1 + 5 '間隔指定 Else Err.Clear 'ErrReset End If End With Next End With Application.ScreenUpdating = True End Sub
< 使用 Excel:Excel2013、使用 OS:Windows10 >
気になる点としては、貼ったオブジェクト名をファイル名に変えていますが、同じファイル名があったりしませんか? 名前変更している行( .Name = …)を、コメントアウトしてみてください。
(???) 2018/08/10(金) 15:17
With ActiveSheet For Each stc In selnm With .Shapes.AddPicture(stc, msoFalse, msoTrue, 0, ico, z1, z1) .Name = Dir(stc, vbNormal) '名前付け ico = ico + z1 + 5 '間隔指定 End With Next End With
しかし、AddPictureは貼るときにサイズを指定する必要があるので、予め幾つにするか決めておかないといけません。必ず横型なら Z1*3/4 とかにもできますが、元が縦型横型混在してもよいロジックになってますよね?
画像ファイルの種類も不特定となると、GDI++とか使って、事前にサイズを得ておく必要があります。 ちょっと面倒なので、まずはご自分で調べてみてください。
(???) 2018/08/10(金) 16:39
Sub Sump_Phot() Const z1 As Single = 255 'サイズ指定 Dim ico As Long, stc As Variant, selnm As Variant Dim P As Object Dim sx As Single Dim sy As Single
selnm = Application.GetOpenFilename(Title:="Ctrl、複数選択OK", MultiSelect:=True) If TypeName(selnm) = "Boolean" Then Exit Sub
ico = 10 '最上位の位置 Application.ScreenUpdating = False
With ActiveSheet For Each stc In selnm Set P = LoadPicture(stc) If P.Width < P.Height Then sx = z1 * P.Width / P.Height sy = z1 Else sx = z1 sy = z1 * P.Height / P.Width End If With .Shapes.AddPicture(stc, msoFalse, msoTrue, 0, ico, sx, sy) .Name = Dir(stc, vbNormal) '名前付け ico = ico + z1 + 5 '間隔指定 End With Next End With
Set P = Nothing Application.ScreenUpdating = True End Sub (???) 2018/08/10(金) 18:01
しかしiPhoneで撮影した縦長写真で上記マクロは横長に潰れてしまうことが確認出来たので、不完全なものであると考えます。
というのも、エクセルのバージョンによって挙動は違うのですが、Excel2013や2016は写真のEXIF情報を元に自動回転するという機能がついています。
従って困ったことにiPhone撮ったような縦長写真は自動的にRotation=90が設定されており、(見た目の)高さがWidthで幅がHeightとなっています。
更に困ったことに、Leftの値からWidth-Height/2だけ右にズレた位置に写真が表示され、Topの値からWidth-Height/2だけ下にズレた位置に写真が表示されます。
???様の言う通りAddPictureは縦横を指定しなければならないのですが、裏技的な方法?としてサイズ0,0で貼り付けた後にLockAspectRatioがTrueの状態でスケールを変化させると比率を保持したまま拡大できます。
これを踏まえて私が使用しているコードを紹介します。
※ただしこのコードには致命的な欠陥があります。左側に余白を設けないと縦長写真のときのみ位置がズレます。
※VBAでLeftにマイナス値を指定すると0に切り上げされるためです。
※手動で左端に配置した写真の.Leftを読み取るとマイナス値が格納出来ているのでなにか方法があるかもしれません。
※対処法を知ってる人がいたら私も知りたいです。
Sub Sump_Phot2() Const LeftMargin = 100 '写真貼り付けの左端 ※(.Width - .Height)/2以上の値に設定すること Const z1 As Single = 255 'サイズ指定 Dim ico As Long, stc As Variant, selnm As Variant Dim P As Object Dim sx As Single Dim sy As Single selnm = Application.GetOpenFilename(Title:="Ctrl、複数選択OK", MultiSelect:=True) If TypeName(selnm) = "Boolean" Then Exit Sub ico = 10 '最上位の位置 Application.ScreenUpdating = False With ActiveSheet For Each stc In selnm With .Shapes.AddPicture(Filename:=stc, _ LinkToFile:=msoFalse, _ SaveWithDocument:=msoTrue, _ Left:=0, _ Top:=0, _ Width:=0, Height:=0) .Name = Dir(stc, vbNormal) '名前付け
.LockAspectRatio = msoTrue .ScaleWidth 1!, msoTrue .Width = z1
If .Rotation = 0 Then .Left = LeftMargin .Top = ico Else '※ .Left = LeftMargin - (.Width - .Height) / 2 .Top = ico + (.Width - .Height) / 2 End If
Debug.Print .Left
ico = ico + z1 + 5 '間隔指定 End With Next End With Set P = Nothing Application.ScreenUpdating = True End Sub
(にゅるん) 2018/08/20(月) 13:21
埋め込み前提でしか使えない回避策ですが、次のようにJPGで再圧縮をすることにより、回転情報を無かったことにできます。
.Width = z1 と If .Rotation = 0 Thenの間に .Cut ActiveSheet.PasteSpecial Format:="図 (JPEG)" End With With Selection.ShapeRange を追加すると問題を回避できます。
しかし、この場合、クリップボードを経由することと、Selectされたシェイプを取得しなければならないので、VBA実行中に他の作業をするとクラッシュするので利用には注意が必要となります。
(にゅるん) 2018/08/20(月) 13:38
教えていただいたマクロで試したところ、きれいに並べられました。
エクセル・写真のドライブを色々動かしてみても写真が消えることもありませんでした。
左側の余白は余計な分は削除するので大丈夫です。これで作業が進められます。
補足までありがとうございます。 そちらを試す際には気を付けます。
(すが) 2018/08/20(月) 13:53
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.