[[20121013073319]]　『excelで資料作りを簡単にしたいとかんがえていまａx（ぺぇ）　ページの最後に飛ぶ

『excelで資料作りを簡単にしたいとかんがえています。』（ぺぇ）

ローカルに拡張Winメタファイル(emf)ファイルがいくつもあり、
Excelのあるセルにemfファイルの名前と同じものを入力すれば、
emfファイルがExcelに（印刷した際、A4横サイズに収まるように）
何個もはりつけいていくマクロを模索しています。

イメージ　O1に入力したファイル名のemfがA1からN39エリアにはりつき
　　　　　02に入力したファイル名のemfがA40からN78エリアに画像がはりつく・・・・

よくある質問より「VBAの企画書作成」というもので似ている内容を見つけたのですが、
引っ張ってくるのはjpegのデータのみで、Winメタファイルの時には機能しません。

思い当たるところを直してできないものか挑戦したのですが、
思うような動作に行き着きませんでした。
どなたかアドバイスいただけますようお願いいたします。

もともとはパワーポイント(A4横)で作成したものページごとに画像として保存でemfに変換してます。
jpegで変換したものでは画像の劣化がネックになり、拡張Winメタファイルでやりたいという思いでおります。

・・・パワーポイントのマクロで随時指定したものだけ抽出できれば一番なのですが、
そのような機能はないようでExcelでと考えました。

ちなみにバージョンは2003です。　2000でも使えれば幸いです。

どうぞよろしくお願いいたします。

↓　参考にさせていただいたマクロです。

 Private Sub Worksheet_Change(ByVal Target As Range)
  Const ImagePath = "C:\dbjpg\"
  Dim picRange As Range
  Dim objPic As Picture
  Dim picPath As String
  Dim myArea As Variant

  myArea = Array("A17:C30", "D17:G30", "H17:K30", "L17:O30", "P17:S30", _
                 "A33:C46", "D33:G46", "H33:K46", "L33:O46", "P33:S46")

  If Application.Intersect(Target, Me.Range("B6:B15")) Is Nothing Then Exit Sub

  Set picRange = Me.Range(myArea(Target.Row - 6))

  For Each objPic In ActiveSheet.Pictures
    If objPic.ShapeRange.Type = msoPicture Then
      If Not Application.Intersect(objPic.TopLeftCell, picRange) Is Nothing Then
        objPic.Delete
        Exit For
      End If
    End If
  Next

  picPath = ImagePath & Target.Value & ".jpg"
  Application.EnableEvents = False
  If Dir(picPath, vbNormal) = "" Then
    picRange.Cells(1, 1).Value = "画像がありません"
  Else
    With Me.Shapes.AddPicture(picPath, msoFalse, msoTrue, picRange.Left, picRange.Top, 1, 1)
      .ScaleHeight 1, msoTrue
      .ScaleWidth 1, msoTrue
      .LockAspectRatio = msoTrue
      .Height = picRange.Height
      If .Width > picRange.Width Then
        .Width = picRange.Width
      End If
    End With
    picRange.ClearContents
  End If
  Application.EnableEvents = True
  End Sub

 >引っ張ってくるのはjpegのデータのみで、Winメタファイルの時には機能しません

 なぜかというとコードの中で画像を挿入しているところ、
 Me.Shapes.AddPicture(picPath, msoFalse, msoTrue, picRange.Left, picRange.Top, 1, 1)
 ここでpicPathに格納されている画像ファイルフルパス文字列（拡張子つき）の中の拡張子が
 picPath = ImagePath & Target.Value & ".jpg"
 と、jpg に固定しているから。

 シートの上で emfファイルを挿入、これをマクロ記録して出来上がるコードを参考にしてみるとどうだろうか？

 追記）↑　ごめん。マクロ記録で出来上がるコードは Pictures.Insert なので、参考にならないね。
　　　いずれにしても現行のコードを使うなら、
　　　picPath = ImagePath & Target.Value & ".jpg"　---> picPath = ImagePath & Target.Value & ".emf"

 (ぶらっと)

ぶらっとさんありがとうございます。

なんてことでしょう・・・。確かに何度か自分でも試したと思っていたのですが、
その時はうんともすんとも・・・。

何日もあれこれ考えていたので、本当に助かりました。　心より感謝します。

コメント返信：

[ 一覧(最新更新順) ]

[[20121013073319]] 『excelで資料作りを簡単にしたいとかんがえていまａx（ぺぇ） ページの最後に飛ぶ

[[20121013073319]]　『excelで資料作りを簡単にしたいとかんがえていまａx（ぺぇ）　ページの最後に飛ぶ