Excel VBA質問箱 IV

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

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


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

4701 / 76732

←次へ　｜　前へ→


	【77647】Re:VBA　画像圧縮

ウッシ - 15/11/18(水) 8:39 -


	引用なし

	パスワード

こんにちは

>目的は
>　指定セルをダブルクリック、フォルダを開き画像選択
>　画像挿入（指定したサイズまたはセルのｗｈ合わせ）、
>　挿入された画像を切り取り、形式（Jpeg）を指定して貼付
>　貼付た画像をセル内で上下センタリング
>としたいのです。

これは元々のコードで出来ているのでは？

ブックのファイルサイズが大きいなら、βさんのリンク先のコードで
出来ると思いますし。

質問の意味がよく分からないですが、

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean)
　　Dim myPic As Variant
　　Dim myRange As Range
　　Dim rX　As Single
　　Dim rY　As Single
　　Dim cht As Chart
　　Dim tmpP As String
　　Dim tmpS As Worksheet
　　Dim tmpR As Range
　　　　
　　'挿入のセルを指定
　　
　　If Application.Intersect(Target, Range("D6,D23,D40")) Is Nothing Then Exit Sub
　　Cancel = True
　　
　　'写真挿入
　　myPic = Application.GetOpenFilename("画像ファイル,*.jpg;*.jpeg;*.gif;*.tif")
　　If myPic = False Then
　　　　Application.ScreenUpdating = True
　　　　MsgBox "画像を選択してください"
　　　　Exit Sub
　　End If
　　
　　Application.ScreenUpdating = False
　　
　　tmpP = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"
　　Set tmpS = Worksheets.Add
　　ActiveWindow.DisplayGridlines = False
　　Set tmpR = tmpS.Range("A1")
　　
　　Set myRange = Target 'このセル範囲に収まるように画像を縮小する
　　　　
　　With Me.Shapes.AddPicture(myPic, False, True, myRange.Left, myRange.Top, myRange.Width, myRange.Height)
　　　　
　　　　rX = 0.85
　　　　rY = 1
　　　　
　　　　If rX > rY Then
　　　　　　.Height = .Height * rY
　　　　Else
　　　　　　.Width = .Width * rX
　　　　End If
　　　　
　　　　tmpR.RowHeight = .Height
　　　　tmpR.ColumnWidth = .Width / 6
　　　　
　　　　.Left = .Left + (myRange.Width - .Width) / 2 '写真を横方向の中央に配置
　　　　.Top = .Top + (myRange.Height - .Height) / 2 '写真を縦方向に中央に配置
　　　　.ZOrder msoSendToBack '最背面へ移動
　　　　　　　　　　　　
　　　　tmpS.Shapes.AddPicture myPic, False, True, tmpR.Left, tmpR.Top, tmpR.Width, tmpR.Height
　　　　
　　　　.Delete
　　　　
　　End With
　　tmpS.Activate
　　tmpR.Select
　　tmpR.CopyPicture appearance:=xlScreen, Format:=xlPicture
　　'画像貼り付け用の埋め込みグラフを作成
　　Set cht = ActiveSheet.ChartObjects.Add(0, 0, tmpR.Width, tmpR.Height).Chart
　　'埋め込みグラフに貼り付ける
　　cht.Paste
　　'JPEG形式で保存
　　cht.Export Filename:=tmpP & Dir(myPic), filtername:="JPG"
　　'埋め込みグラフを削除
　　cht.Parent.Delete
　　
　　With Me.Shapes.AddPicture(tmpP & Dir(myPic), False, True, myRange.Left, myRange.Top, myRange.Width, myRange.Height)
　　　　
　　　　rX = 0.85
　　　　rY = 1
　　　　
　　　　If rX > rY Then
　　　　　　.Height = .Height * rY
　　　　Else
　　　　　　.Width = .Width * rX
　　　　End If
　　　　.Left = .Left + (myRange.Width - .Width) / 2 '写真を横方向の中央に配置
　　　　.Top = .Top + (myRange.Height - .Height) / 2 '写真を縦方向に中央に配置
　　　　.ZOrder msoSendToBack '最背面へ移動
　　　　
　　　　Kill tmpP & Dir(myPic)
　　　　　　　　
　　End With
　　Application.DisplayAlerts = False
　　tmpS.Delete
　　Application.DisplayAlerts = True
　　Application.ScreenUpdating = True
　　Cancel = True

End Sub

とかでは、余計にダメでしょうか？

6 hits

▼

【77636】VBA　画像圧縮 SEWING11 15/11/14(土) 22:45