エクセルの画像リンク解除

質問

Pictures.Insert　で書かれた内容を
Shapes.AddPicture　の構文に変更したいのですが、
VBAの知識が乏しいので、なかなかうまくいきません。
どなたかわかる方はいらっしゃいますでしょうか？
宜しくお願いします。

Sub Test()
Range("B3").Select

Dim fName, pict As Picture

fName = Application.GetOpenFilename("JPG, *.jpg", MultiSelect:=True)

If IsArray(fName) Then
For i = 1 To UBound(fName)
Set pict = ActiveSheet.Pictures.Insert(fName(i))
pict.TopLeftCell = ActiveCell
pict.Width = ActiveCell.Width * 2
pict.Height = ActiveCell.Height * 6
ActiveCell.Offset(7, 0).Activate
Next i
End If
End Sub

回答No.3

real beatin（@realbeatin） · ベストアンサー

> 画像を小さく張り付けているので、
> 解像度も同時に小さくなっています。
> 解像度をそのままで貼り付けはできそうですか？

> こちらも試しましたが、
> やはり、画像解像度かなり小さくなってしまいました。
> なにとぞよろしくお願いします。

画質を重視しているのなら、そうと分かるように
タイトルや質問本文を書いておいた方が良かったですね。
技術的には似て非なるもので、私にとっては守備範囲外のジャンルですから、
その課題に応えるに相応しい識者に委ねたいところですが、
一応、私なりの答えは用意しました。
もし解決に至らなかったとしたら、
質問を建て直して、専門的な情報を持った方の眼に触れ興味を引き易いように。
工夫した方が解決の可能性は高まるかと思います。

> 画像を小さく張り付けているので、
> 解像度も同時に小さくなっています。
小さく貼り付けたせいで画像が圧縮され、解像度が低くなる、
という意味で仰っているのなら、
Excelデフォルトの設定では、そういう仕様です。
つまり再び原寸に戻しても元の画質からの劣化が著しいという意味ですよね？

　[詳細設定]
　　[イメージのサイズと画質]　　（←ブック限定の設定）
　　　[ファイル内のイメージを圧縮しない]　にチェック
　　[印刷]　　（←Excelの設定）
　　　[グラフィック用の印刷モード]　にチェック
まずはオプション設定を確認、または変更してください。

ソースが.jpg ですから、
編集（トリミングやリサイズ、縦横比変更）、保存する
都度都度、ファイルは圧縮されていくことはExcelだけの問題でもなくて
程度の差はあれど圧縮は起きる、という風に私は理解していますけれど。
また、Excelが自動で画像を極端なレベルで圧縮するのは、
ファイルサイズの肥大化を敬遠する方が多いという背景があってのことだと思います。
画質とファイルサイズの最適化は、ある意味でバーターですね。

不得手なジャンルですので、時間を限ったの中で見つけただけの暫定回答ですけれど、
上述のオプション設定を事前に済ませた上で、
ImageコントロールにLoadPictueして、
CopyPictueして、[図 (拡張メタファイル)]として貼付けてみました。
紙に印刷まではしていませんが、PDFに出力した際の目視の判断では、
こちらでの環境である程度の改善がみられるように思われます。
どの程度のことを期待されているのかにもよると思うのですが、
うまく行かなかったとしても、すみません、今の私にはここまで、です。
解決に近づけることを祈っています。

' ' ///

Sub Re9090551img2meta()
Dim oImage As OLEObject
Dim fName, x, y
Dim i As Long
　　fName = Application.GetOpenFilename("JPG, *.jpg", MultiSelect:=True)
　　If IsArray(fName) Then
　　　　Application.ScreenUpdating = False
　　　　With Cells(3, "B")
　　　　　　.Select
　　　　　　x = .Width * 2:　　y = .Height * 6
　　　　End With
　　　　With ActiveCell
　　　　　　Set oImage = ActiveSheet.OLEObjects.Add( _
　　　　　　　　ClassType:="Forms.Image.1", Link:=False, DisplayAsIcon:=False, _
　　　　　　　　Left:=.Left, Top:=.Top, Width:=x, Height:=y)
　　　　End With
　　　　With oImage.Object
　　　　　　.AutoSize = True
　　　　　　.BackStyle = 0　'　fmBackStyleTransparent
　　　　　　.BorderStyle = 0　'　fmBorderStyleNone
　　　　End With
　　　　For i = 1 To UBound(fName)
　　　　　　oImage.Object.Picture = LoadPicture(fName(i))
　　　　　　DoEvents: DoEvents
　　　　　　oImage.CopyPicture
　　　　　　ActiveSheet.PasteSpecial _
　　　　　　　　Format:="図 (拡張メタファイル)", _
　　　　　　　　Link:=False, _
　　　　　　　　DisplayAsIcon:=False
　　　　　　With ActiveSheet.Shapes
　　　　　　　　With .Item(.Count)
　　　　　　　　　　.Width = x:　　.Height = y
　　　　　　　　End With
　　　　　　End With
　　　　　　Cells(i * 7 + 3, "B").Select
　　　　Next i
　　　　oImage.Delete
　　　　Application.ScreenUpdating = True
　　End If
End Sub

' ' ///

お礼

色々とご尽力いただきありがとうございました。

最初に教えていただいたものがわかりやすく、
使い勝手がよかったので、そちらでいくことに決めました。

今回初めてこのサイトに相談させて頂いたのですが、
こんなに早く、的確に、丁寧に回答頂いたことに感激しいます。
ありがとうございました。

回答No.2

real beatin（@realbeatin）

回答No.1です。追記します。

ご質問のタイトルと内容とが少し違っていることが気になったのですが、
> Shapes.AddPicture　の構文に変更したい
ということよりも
> エクセルの画像リンク解除
ということを意図されてのご質問だった場合は、
ご提示のコードで貼付けが済んでいる画像を
[リンクされた図]ではなくて[図として貼り付け]し直すことも可能です。
本文では訊かれてはいないことですが、一応の参考になれば、と、、、。

' ' /// 参考URL xls88_1さんのスクリプト が簡単で解り易いので拝借/転用しました。

Sub エクセルの画像リンク解除()
Dim pict As Picture
Dim x, y
　　With ActiveSheet
　　　　For Each pict In .Pictures
　　　　　　If pict.ShapeRange.Type = msoLinkedPicture Then
　　　　　　　　x = pict.Left:　 y = pict.Top
　　　　　　　　pict.Cut
　　　　　　　　.PasteSpecial Format:="図 (JPEG)"
　　　　　　　　With .Pictures(.Pictures.Count)
　　　　　　　　　　.Left = x:　 .Top = y
　　　　　　　　End With
　　　　　　End If
　　　　Next
　　End With
End Sub

' ' ///

参考URL：

http://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q13120577183

お礼

ありがとうございました。
こちらも試しましたが、
やはり、画像解像度かなり小さくなってしまいました。
なにとぞよろしくお願いします。

回答No.1

real beatin（@realbeatin）

こんにちは。

こんな感じ。

' ' ///

Sub Re9090551a()

Dim fName, pict As Picture
Dim i As Long

　　Range("B3").Select
　　fName = Application.GetOpenFilename("JPG, *.jpg", MultiSelect:=True)

　　If IsArray(fName) Then
　　　　For i = 1 To UBound(fName)
　　　　　　With ActiveCell
　　　　　　　　Set pict = ActiveSheet.Shapes.AddPicture( _
　　　　　　　　　　Filename:=fName(i), _
　　　　　　　　　　LinkToFile:=False, SaveWithDocument:=True, _
　　　　　　　　　　Left:=.Left, Top:=.Top, Width:=.Width * 2, Height:=.Height * 6).DrawingObject
　　　　　　　　.Offset(7, 0).Select
　　　　　　End With
　　　　Next i
　　End If
End Sub

' ' ///

もし、Picture型に拘らないなら、Shape型で
Dim pict As Shape
　　　　　　　　Set pict = ActiveSheet.Shapes.AddPicture( _
　　　　　　　　　　Filename:=fName(i), _
　　　　　　　　　　LinkToFile:=False, SaveWithDocument:=True, _
　　　　　　　　　　Left:=.Left, Top:=.Top, Width:=.Width * 2, Height:=.Height * 6)
とか、オブジェクトとして捉える必要（Pictureに対する他の処理）がないなら、
　　　　　　　　ActiveSheet.Shapes.AddPicture _
　　　　　　　　　　Filename:=fName(i), _
　　　　　　　　　　LinkToFile:=False, SaveWithDocument:=True, _
　　　　　　　　　　Left:=.Left, Top:=.Top, Width:=.Width * 2, Height:=.Height * 6
とかで。

お礼

迅速な回答ありがとうございました。

一点何とかならないかなということがあるのですが、
画像を小さく張り付けているので、
解像度も同時に小さくなっています。
解像度をそのままで貼り付けはできそうですか？
何度も申し訳ないですが、よろしくお願いします。