Excel VBA質問箱 IV

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

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


900 / 13644 ツリー ←次へ | 前へ→

【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 お礼[未読]

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

引用なし
パスワード
   お世話になります。
OKweb様へも質問しましたが回答がつかないので・・・

エクセル2010を使用しています。写真帳を作成しダブルクリックすれば写真が挿入されるようVBAにて作成しましたが、写真の解像度が高いので挿入するたびに画像が圧縮するようにVBAを組みたいのですが、どなたかご教示ください。
具体的には一同挿入した画像を一度コピーし、再度貼り付ける・・・という動作かなと考えているのですが、マクロの記憶では記録されず・・・困っております。

現在の写真帳の構文は
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean)

Dim myF As Variant
Dim mySp As Object
Dim myAD1 As String
Dim myAD2 As String
Dim myHH As Double
Dim myWW As Double
Dim myHH2 As Double
Dim myWW2 As Double


'挿入のセルを指定

If Application.Intersect(Target, Range("d6,d23,d40")) Is Nothing Then Exit Sub
Cancel = True
Application.ScreenUpdating = False


End If


'写真挿入

Next
myPic = Application.GetOpenFilename("画像ファイル,*.jpg;*.jpeg;*.gif;*.tif")
If myPic = False Then
MsgBox "画像を選択してください"

Exit Sub

End If


Set myRange = Target 'このセル範囲に収まるように画像を縮小する
Application.ScreenUpdating = False
With ActiveSheet.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
.Left = .Left + (myRange.Width - .Width) / 2 '写真を横方向の中央に配置
.Top = .Top + (myRange.Height - .Height) / 2 '写真を縦方向に中央に配置
.ZOrder msoSendToBack '最背面へ移動

End With
Application.ScreenUpdating = True
Cancel = True

End Sub

上記に.CUT などを書き足せばよいのか・・・
→エラーばかりで動かなったので。。
 こちらに質問することにしました。
どうぞ、よろしくお願いします。

【77637】Re:VBA 画像圧縮
発言  β  - 15/11/15(日) 6:10 -

引用なし
パスワード
   ▼SEWING11 さん:

>現在の写真帳の構文は

現在のコードから取捨選択して必要と思われる部分をアップしたんでしょうね。
ぽつんと Next が残っていたりしますので。

アップされたコードの手直しではなく、別の板ですがほぼ同じ要件で投稿したコードがあります。
//www.excel.studio-kazu.jp/kw/20151106133015.html
この中の (β) 2015/11/07(土) 12:32 のコードが参考になりませんか?

【77638】Re:VBA 画像圧縮
お礼  SEWING11  - 15/11/15(日) 16:02 -

引用なし
パスワード
   回答ありがとうございます。
ご指摘の通り途中、挿入先のセルに画像が残っていた場合は削除する。という記述を省略したので、中途半端に載せてしまいすみませんでした。

参照先を確認しました。
セル内へサイズの圧縮を行って挿入する記述ですね。参考にいたします。

目的は画像のファイルサイズ圧縮なので、このままでは圧縮されないですよね?
もう少し検索して模索します。
ありがとうございました。

【77639】Re:VBA 画像圧縮
発言  β  - 15/11/15(日) 17:17 -

引用なし
パスワード
   ▼SEWING11 さん:

>目的は画像のファイルサイズ圧縮なので、このままでは圧縮されないですよね?

画像ファイルという意味が、画像がベタベタ、大きなサイズで多数貼り付けられているものをいっておられるとすれば
ご紹介した処理での加工で、サイズ圧縮はされます。

たとえば、なにもせずにどんどん元の大きさのままで張り付けると10メガ程度のブックサイズになるケースで
このコードで実行しますと2メガ程度に小さくなりました。

画像ファイルというのが、もともとフォルダにある画像ファイルのことをいっていられるとすれば
このコードではだめですね。
というか、もし、そうなら、エクセルに取り込む前に(あるいは取り込み時点で)
画像ファイルそのものを圧縮したものを取り込むことが必要ですね。

【77640】Re:VBA 画像圧縮
発言  マナ  - 15/11/15(日) 21:11 -

引用なし
パスワード
   ▼SEWING11 さん:
> 具体的には一同挿入した画像を一度コピーし、再度貼り付ける・・・という動作かなと考えているのですが、マクロの記憶では記録されず・・・困っております。

>
>上記に.CUT などを書き足せばよいのか・・・


マクロ記録の結果です。
Selection.Cut
ActiveSheet.PasteSpecial Format:="図 (JPEG)", Link:=False, DisplayAsIcon:=False

【77641】Re:VBA 画像圧縮
お礼  SEWING11  - 15/11/15(日) 21:38 -

引用なし
パスワード
   >β様
再び回答ありがとうございます。経緯の説明が不足していますね。申し訳ありません。画像ファイルの圧縮とは元データの事を指します。
写真整理で使用しているのですが、複数人へ配付して利用しております。
自分で使うのであれば、元画像データ(写真)をリサイズして貼り付けるのですが、配付先はPCに苦手な方が多く、何も考えず貼り付ければ勝手に圧縮されるというのが理想なのです。(工事写真なのですが、20M超えのファイルを送り返してくるので・・・)
説明不足で、申し訳ありませんでした。


>マナ様
回答ありがとうございます。
記載いただいた構文を追記してみます。

【77644】Re:VBA 画像圧縮
回答  ウッシ  - 15/11/17(火) 8:43 -

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

セルに貼り付けた画像のサイズにして良ければ、

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean)
  Dim myF As Variant
  Dim mySp As Object
  Dim myAD1 As String
  Dim myAD2 As String
  Dim myHH As Double
  Dim myWW As Double
  Dim myHH2 As Double
  Dim myWW2 As Double
  Dim myPic As Variant
  Dim myRange As Range
  Dim rX As Single
  Dim rY As Single
  Dim cht As Chart
  
  '挿入のセルを指定
  
  If Application.Intersect(Target, Range("D6,D23,D40")) Is Nothing Then Exit Sub
  Cancel = True
  Application.ScreenUpdating = False
  
  '写真挿入
  myPic = Application.GetOpenFilename("画像ファイル,*.jpg;*.jpeg;*.gif;*.tif")
  If myPic = False Then
    Application.ScreenUpdating = True
    MsgBox "画像を選択してください"
    Exit Sub
  End If
  
  Set myRange = Target 'このセル範囲に収まるように画像を縮小する
  Application.ScreenUpdating = False
  With ActiveSheet.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
    .Left = .Left + (myRange.Width - .Width) / 2 '写真を横方向の中央に配置
    .Top = .Top + (myRange.Height - .Height) / 2 '写真を縦方向に中央に配置
    .ZOrder msoSendToBack '最背面へ移動
    
    Kill myPic
        
  End With
  
  myRange.Select
  myRange.CopyPicture appearance:=xlScreen, Format:=xlPicture
  '画像貼り付け用の埋め込みグラフを作成
  Set cht = ActiveSheet.ChartObjects.Add(0, 0, myRange.Width + 1, myRange.Height + 1).Chart
  '埋め込みグラフに貼り付ける
  cht.Paste
  'JPEG形式で保存
  cht.Export Filename:=myPic, filtername:="JPG"
  '埋め込みグラフを削除
  cht.Parent.Delete
  
  Application.ScreenUpdating = True
  Cancel = True

End Sub

とかでどうでしょうか?

元画像を削除しますのでテスト環境で試して下さい。

【77646】Re:VBA 画像圧縮
お礼  SEWING11  - 15/11/18(水) 0:15 -

引用なし
パスワード
   ウッシ様

回答ありがとうございます。
記載頂いたコードを試しました。
元画像ファイルのサイズが変わるのですね!
 →こんな動作もできるのですね。

ただ、今回求めている動作とは少し違いました。
申し訳ありません。

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

.Cut
End With
Me.PasteSpecial Format:="図 (JPEG)"

等、記載しているのですが、うまく動作せず・・・
試行錯誤しております。
回答、ありがとうございました。

【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

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

【77648】Re:VBA 画像圧縮
発言  β  - 15/11/18(水) 8:49 -

引用なし
パスワード
   ▼SEWING11 さん:

横から失礼。

>ただ、今回求めている動作とは少し違いました。
>申し訳ありません。

違っているのは

1.画像圧縮
2.サイズ変更
3.圧縮・サイズ変更した結果をセル領域の中心に配置

この、どれですか?

もし、3.であれば

.Left = myRange.Left + (myRange.Width - .Width) / 2 '写真を横方向の中央に配置
.Top = myRange.Top + (myRange.Height - .Height) / 2 '写真を縦方向に中央に配置

としなければいけないのでは?

(私がご紹介したコードでは、そうしております)

【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 -

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

結局、ブックのファイルサイズの圧縮の事のようなので、βさんのコードのように

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
    
  '挿入のセルを指定
  
  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
    
  Set myRange = Target 'このセル範囲に収まるように画像を縮小する
    
  With ActiveSheet.Pictures.Insert(myPic)

    .ShapeRange.LockAspectRatio = msoTrue
    
    .Width = myRange.Width
    If .Height > myRange.Height Then .Height = myRange.Height
    .Left = myRange.Left + myRange.Width / 2 - .Width / 2
    .Top = myRange.Top + myRange.Height / 2 - .Height / 2
    
  End With
  
  Application.ScreenUpdating = True
  Cancel = True

End Sub

とすれば良いと思います。

【77659】Re:VBA 画像圧縮
お礼  SEWING11  - 15/11/18(水) 18:14 -

引用なし
パスワード
   ウッシ様
回答ありがとうございます!
私の書き方が悪いのでしょうね・・・申し訳ないです。
ブックのファイルサイズを下げることが勿論目的なのですが
貼付ける画像毎にサイズダウンをさせたいのです。

今回記述頂いたコードで目的とする動きは完璧にできています。
ここへ

'JPEG形式で保存
  cht.Export Filename:=tmpP & Dir(myPic), filtername:="JPG"

または
Selection.Cut
ActiveSheet.PasteSpecial Format:="図 (JPEG)", Link:=False, DisplayAsIcon:=False

など、挿入した画像を一度カットし、形式を変えて貼付けという動作を
組込たいのです。

前に頂戴したコードで画像がサイズダウンされていましたので
それを元に試行錯誤してみます。
何度もアドバイス有難うございました!

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