Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

3873 / 76734

←次へ　｜　前へ→


	【78490】Re:画像をJPEGに変換

ちろ - 16/10/8(土) 11:46 -


	引用なし

	パスワード

βさん
アドバイスいただきありがとうございました。

ご紹介いただいたページや他のページを参考に試行錯誤してますが
残念ながら未だに完成しておりません。
何処が悪いのでしょうか。

ご教授いただけないでしょうか。

Public Sub CCC()

Dim myRange As Range '画像を配置するセル範囲
Dim rX, rY As Double
Dim myDhape, myPic As Variant
Dim Cancel As Boolean
Dim SpObj As Object
　 Dim sp As Shape

　
myPic = Application.GetOpenFilename("画像ファイル,*.jpg;*.jpeg;*.gif;*.tif")
If VarType(myPic) = vbBoolean Then Exit Sub

Set myRange = ActiveCell.MergeArea 'このセル範囲に収まるように画像を縮小する
　　　
Application.ScreenUpdating = False

With ActiveSheet.Pictures.Insert(myPic).ShapeRange
　 rX = myRange.Width / .Width
　 rY = myRange.Height / .Height
　If rX > rY Then
　　.Height = .Height * rY
　　Else
　　.Width = .Width * rX
　End If
　
　
　'----------------------追加--------------------------------------------
'For Each sp In ActiveSheet.Shapes
　　Set sp = Range(sp.TopLeftCell, sp.BottomRightCell)
　　　　　 sp.Select
　　　　　　Selection.Cut
　　　　　　ActiveSheet.PasteSpecial Format:="図 (JPEG)", Link:=False, DisplayAsIcon:=False
　　　　　　DoEvents
　　　　　　With ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
　　　　　　　　.Left = ActiveCell.Left + (myRange.Width - .Width) / 2 '写真を横方向の中央に配置
　　　　　　　　.Top = ActiveCell.Top + (myRange.Height - .Height) / 2 '写真を縦方向に中央に配置
　　　　　　End With
' Next

'--------------------------------------------------------------------
　　　
End With

Application.ScreenUpdating = True
Cancel = True

End Sub

3 hits

▼

【78483】画像をJPEGに変換 ちろ 16/10/5(水) 21:17