[[20180810145912]]　『イメージ画像？で張り付けていた昔の写真張り付け』（すが）　ページの最後に飛ぶ

『イメージ画像？で張り付けていた昔の写真張り付けのマクロの変更』（すが）

すごく昔にエクセルへの写真張り付けのマクロを作っていただきました。

久々使ったところ、昔と違って写真のフォルダを動かすと、表示できません
「リンクされたイメージの表示ができません」のメッセージが出てしまいます。

今は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 ＞

Excel2010で動作したので、2013でも動くはずですよ？

気になる点としては、貼ったオブジェクト名をファイル名に変えていますが、同じファイル名があったりしませんか？名前変更している行（ .Name = …）を、コメントアウトしてみてください。
（???） 2018/08/10(金) 15:17

たぶんマクロは動くんですよね。
でもPictures.Insertは画像データがブックに埋め込まれないので保存フォルダが変わると読み込めなくなると。
http://www.moug.net/tech/exvba/0120020.html
（名無し） 2018/08/10(金) 15:23

なるほど、リンク貼り付けになっていた方の問題っぽいですね。なら、変えないとですが、ちょっとコード書く余裕なし…。
（???） 2018/08/10(金) 15:28

返信ありがとうございます。
はい、マクロは動きますし、作った直後は大丈夫なのですが、その後写真データや
エクセルの場所を動かすとダメになります。
（すが） 2018/08/10(金) 15:41

命令を変えるだけなら、以下のようにします。

    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

正確に画素数を得なくとも、縦横比だけ判れば十分のようなので、面倒なAPIのGDI++を使う代わりに LoadPicture を使ってみました。これなら簡単でしょう。

 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

すごい、こんなに早くありがとうございます。
GDI++とか聞いて調べてもちんぷんかんぷんでしたので助かりました。
本当にありがとうございました。
（すが） 2018/08/10(金) 20:53

先日作っていただいたマクロ、写真が正方形で並んでしまいます(縦が長くなる)。
せめて縦横比は自分でと思ったのですが、どうにも分かりませんでした。
どこをどうすれば縦横比同じまま縮小貼り付けできるのでしょうか？
（すが） 2018/08/20(月) 11:14

＞先日作っていただいたマクロ、写真が正方形で並んでしまいます(縦が長くなる)。
これについては同一の写真を所有していないので再現出来ませんでした。

しかし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

コメント返信：

[ 一覧(最新更新順) ]

[[20180810145912]] 『イメージ画像？で張り付けていた昔の写真張り付け』（すが） ページの最後に飛ぶ

[[20180810145912]]　『イメージ画像？で張り付けていた昔の写真張り付け』（すが）　ページの最後に飛ぶ