エクセルでの画像貼り付け時のサイズ変換

質問

エクセルについて教えてください。
ペイントソフトなどで画像修正したあと、そのままコピー（クリップボードに）し、エクセルに任意の大きさで貼り付けたいのですが、そんなマクロできるでしょうか。

方法としては、自分が貼り付けたい大きさに結合したセルを選択し、貼り付け（クリップボードなので、右クリック貼り付け）をすると、そのセルの大きさに自動で縮小・拡大するような仕組みです。

いろいろな掲示板を見て、クリップボードからではなく、挿入から画像を選んで任意のセルの大きさで貼り付けるというマクロは発見できました。
それをちょっといじるとできそうな気がするんですが、なにぶん詳しくないもので、、、
だれかわかる方教えてください。

↓挿入からセルの大きさに合わせて貼り付けるマクロ

Sub haritukeru()
Dim c As Range, cm As Range
Application.ScreenUpdating = False
For Each c In Selection
Set cm = c.MergeArea
If c.Address = cm.Item(1).Address Then
If Application.Dialogs(xlDialogInsertPicture).Show = False Then Exit Sub
With Selection
.Left = cm.Left
.Top = cm.Top
.Height = cm.Height
.Width = cm.Width
End With
End If
Next
Set cm = Nothing
Application.ScreenUpdating = True
End Sub

回答No.1

Wendy02 · ベストアンサー

こんにちは。

しばらく、やってみましたが、今のところ、私には完全には出来ません。

理由は、
＞そのままコピー（クリップボードに）し、エクセルに任意の大きさで貼り付けたいのですが、

これ自体はできるのですが、問題は、貼り付ける際に、その確保したクリップボードの中身のタイプが何かというのが分らないと、誤動作が出てしまいます。もう少しやってみますので、出来ても出来なくても、もう一度、ここに書きます。

お礼

ありがとうございます、よろしくお願いします。

回答No.3

Wendy02

こんばんは。

＞元画像より大きい枠での拡大処理はなったんですが、縮小処理は無理ですか？

私のほうは、jpg ファイルで試してみたのですが、縮小も出来ました。
もし、うまくいかないようでしたら、ワークシート上の貼り付けた画像を、右クリックコピーで、縮小サイズで、試してみてください。

回答No.2

Wendy02

こんばんは。

コントロールツールのコマンドボタンを押して貼り付けるように作りましたので、もし、違う形にしていようでしたら、他に移植してください。

手順としては、最初に、Pictureをコピーして、それから、Excelのワークシート上で、ボタンを押すと、InputBox が出てきて、範囲を設定するように求められます。それで範囲が設定したら、Ok をクリックすれば、Pictureの大きさが定まって、貼り付けられます。

'シートモジュール
'------------------------------------------------------------
Private Declare Function IsClipboardFormatAvailable _
　　Lib "user32.dll" _
　 (ByVal wFormat As Long) As Long
Private Const CF_BITMAP = 2
Private Const CF_METAFILEPICT = 3

Private Sub CommandButton1_Click()
　 Dim rng As Range
　 Dim mLeft As Double
　 Dim mTop As Double
　 Dim mHeight As Double
　 Dim mWidth As Double
　 Dim cf As Variant
　 Dim clpFlg As Boolean

　 For Each cf In Array(CF_METAFILEPICT, CF_BITMAP)
　　　' クリップボードのデータ形式を判定
　　　If IsClipboardFormatAvailable(CLng(cf)) Then
　　　　 clpFlg = True
　　　End If
　 Next cf

　 If clpFlg = False Then
　　　MsgBox "画像が確保されいてません。", 32:　 Exit Sub
　 End If
　 On Error Resume Next
　 Set rng = Application.InputBox("領域を選択してください。", Type:=8)
　 If rng Is Nothing Then Exit Sub
　 On Error GoTo 0

　 If rng.Count = 1 Then
　　　MsgBox "領域を広げてください。", 32:　　Exit Sub
　 End If

　 With rng
　　　mLeft = .Left
　　　mTop = .Top
　　　mHeight = .Cells(.Count).Offset(1).Top - .Top
　　　mWidth = .Cells(.Count).Offset(, 1).Left - .Left
　 End With

　 On Error GoTo EndLine

　 Me.Pictures.Paste
　 With Me.Pictures(Me.Pictures.Count).ShapeRange
　　　.Left = mLeft
　　　.Top = mTop
　　　.Height = mHeight
　　　.Width = mWidth
　　　.LockAspectRatio = msoFalse
　　　.LockAspectRatio = msoFalse
　　　.Parent.Visible = msoTrue
　 End With
Exit Sub
EndLine:
　　MsgBox Err.Number & ":" & Err.Description

End Sub

補足

元画像より大きい枠での拡大処理はなったんですが、縮小処理は無理ですか？
すいません、よろしくお願いします。