Excel VBA質問箱 IV

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

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


4701 / 76732 ←次へ | 前へ→

【77647】Re:VBA 画像圧縮
回答  ウッシ  - 15/11/18(水) 8:39 -

引用なし
パスワード
   こんにちは

>目的は
> 指定セルをダブルクリック、フォルダを開き画像選択
> 画像挿入(指定したサイズまたはセルのwh合わせ)、
> 挿入された画像を切り取り、形式(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 質問[未読]
【77637】Re:VBA 画像圧縮 β 15/11/15(日) 6:10 発言[未読]
【77638】Re:VBA 画像圧縮 SEWING11 15/11/15(日) 16:02 お礼[未読]
【77639】Re:VBA 画像圧縮 β 15/11/15(日) 17:17 発言[未読]
【77640】Re:VBA 画像圧縮 マナ 15/11/15(日) 21:11 発言[未読]
【77641】Re:VBA 画像圧縮 SEWING11 15/11/15(日) 21:38 お礼[未読]
【77644】Re:VBA 画像圧縮 ウッシ 15/11/17(火) 8:43 回答[未読]
【77646】Re:VBA 画像圧縮 SEWING11 15/11/18(水) 0:15 お礼[未読]
【77647】Re:VBA 画像圧縮 ウッシ 15/11/18(水) 8:39 回答[未読]
【77648】Re:VBA 画像圧縮 β 15/11/18(水) 8:49 発言[未読]
【77649】Re:VBA 画像圧縮 SEWING11 15/11/18(水) 9:42 お礼[未読]
【77653】Re:VBA 画像圧縮 SEWING11 15/11/18(水) 12:44 お礼[未読]
【77654】Re:VBA 画像圧縮 ウッシ 15/11/18(水) 14:05 回答[未読]
【77659】Re:VBA 画像圧縮 SEWING11 15/11/18(水) 18:14 お礼[未読]

4701 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free