VBAについて教えてください

もともと添付されている画像は何もせず、図の挿入で追加した画像のみ、pngからjpg形式に変換。また、リサイズしてExcelに貼り付けたいです。

もともと貼ってある図まで切り取りされ、jpgに変換されてしまうのですが、どこを変更したらよいでしょうか？

Sub resize()

Application.Dialogs.Item(xlDialogInsertPicture).Show

With Selection

.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 100
.ShapeRange.Width = 300


Dim sp As Shape
Dim l As Double
Dim t As Double
For Each sp In ActiveSheet.Shapes
If sp.Type = msoPicture Then
l = sp.Left
t = sp.Top
sp.Select
Selection.Cut
ActiveSheet.PasteSpecial Format:="図 (JPEG)", Link:=False, DisplayAsIcon:=False

With ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
.Left = l
.Top = t
End With
End If
Next
End With

End Sub

No.6 ベストアンサー 回答者： gao57830 回答日時： 2015/12/13 21:03

複数選択可能にしました。

Sub resize()
Dim fName As Variant
Dim png As Variant

fName = Application.GetOpenFilename("pngファイル, *.png", MultiSelect:=True)
If IsArray(fName) Then
For Each png In fName
With ActiveSheet.Pictures.Insert(png)
.TopLeftCell = ActiveCell
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 100
.ShapeRange.Width = 300
.Cut
End With
ActiveSheet.PasteSpecial Format:="図 (JPEG)", Link:=False, DisplayAsIcon:=False
ActiveCell.Offset(2, 0).Activate
Next png
End If
End Sub

この回答へのお礼

ありがとうございました。完璧です！読解して、勉強したいと思います。

お礼日時：2015/12/14 16:14

No.5 回答者： gao57830 回答日時： 2015/12/12 18:33

これでどうですか？

Sub resize()
Dim fName As String
Dim aRng As Range
Set aRng = ActiveCell

fName = Application.GetOpenFilename("pngファイル, *.png")
If fName <> "False" Then
With ActiveSheet.Pictures.Insert(fName)
.TopLeftCell = aRng
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 100
.ShapeRange.Width = 300
.Cut
End With
aRng.Select
ActiveSheet.PasteSpecial Format:="図 (JPEG)", Link:=False, DisplayAsIcon:=False
ActiveCell.Offset(2, 0).Activate
End If
End Sub

ただ、これでは元のpng画像が消えない？と思うので、その場合は、
.Cut
の下に、以下のように２行追加してください。

.Cut
.CopyPicture 'クリップボードにコピー
.Delete '画像をいったん削除
End With

この回答へのお礼

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

ファイル1枚の場合、.Cutの下に2行を追加しなくても成功しました。

ただし

1.ファイルを選択することが1枚しかできません。
複数枚pngファイルを選択したいです。


2. ファイルを1枚選択した場合で、.Cutの下2行追加しましたが、.CopyPictureのところで、PictureクラスのCopy Pictureメソッドが失敗しましたと、エラーがでます。

お礼日時：2015/12/13 18:18

No.4 回答者： gao57830 回答日時： 2015/12/10 21:58

ActiveSheet.PasteSpecial Format:="図 (JPEG)", Link:=False, DisplayAsIcon:=False

この行の下に
ActiveCell.Offset(20, 0).Activate
を追加したらどうですか？

この回答へのお礼

ご回答ありがとうございます。

申し訳ありませんが、

Sub resize()
Application.Dialogs.Item(xlDialogInsertPicture).Show
With Selection
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 100
.ShapeRange.Width = 300
.Cut
End With
ActiveSheet.PasteSpecial Format:="図 (JPEG)", Link:=False, DisplayAsIcon:=False
ActiveCell.Offset(20,0).Activate
End Sub

でも、

Sub resize()

yy=1

Application.Dialogs.Item(xlDialogInsertPicture).Show
With Selection
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 100
.ShapeRange.Width = 300
.Cut
End With

Range("A" &yy).Select
With Selection

yy=yy+10

End With

ActiveSheet.PasteSpecial Format:="図 (JPEG)", Link:=False, DisplayAsIcon:=False
End Sub


こちらでも、できませんでした。

どこを修正したらよいでしょうか？

お礼日時：2015/12/12 16:34

No.3 回答者： gao57830 回答日時： 2015/12/10 19:15

画像は、現在選択しているセルに貼り付けられるので

選択されているセルを移動させてやればよいです。
勝手に移動させるなら、以下のようにすれば良いと思います。


Dim yy = 1

Sub resize()
Application.Dialogs.Item(xlDialogInsertPicture).Show
Range("A" & yy).Select
With Selection

yy = yy + 10
End Sub

この回答へのお礼

ご回答ありがとうございます。
何度も申し訳ありませんが、今回答いただいたものと組み合わせしてもうまくいきません。

お手数ですが、1枚毎バラバラに貼り付けでき、リサイズと、pngからjpgへ変換もできる組み合わせで回答いただけると助かります。

本当に何度も申し訳ありませんが、ご回答の程よろしくお願い致します。

お礼日時：2015/12/10 20:11

No.2 回答者： gao57830 回答日時： 2015/12/09 21:33

これでよいかはわかりませんが、必要なのはこのくらいだと思います。

Sub resize()
Application.Dialogs.Item(xlDialogInsertPicture).Show
With Selection
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 100
.ShapeRange.Width = 300
.Cut
End With
ActiveSheet.PasteSpecial Format:="図 (JPEG)", Link:=False, DisplayAsIcon:=False
End Sub

この回答へのお礼

ありがとうございます。
1枚の画像には有効でした。
複数枚を取り込むと、複数枚が1つの画像になってしまうようです。

1枚1枚バラバラに貼り付けする方法があれば教えていただけると助かります。

お礼日時：2015/12/10 18:13

No.1 回答者： gao57830 回答日時： 2015/12/09 19:30

エクセルVBAが使用出来る環境が無いので、ソースを見ただけですが・・・。

For Each sp In ActiveSheet.Shapes

Next

このForループで全ての画像を処理していると思いますが？？？
なぜ？このForループが必要なのですか？

この回答へのお礼

gao57830さま
ご回答ありがとうございます。ループは不要です。どのように修正したらよいでしょうか？VBAを勉強中のため、教えていただけると助かります。

お礼日時：2015/12/09 20:44