[[20151117185211]] 『写真挿入後に圧縮し、センタリング』(Rin) ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『写真挿入後に圧縮し、センタリング』(Rin)

お世話になります。
ダブルクリックをした箇所へ写真を挿入するというVBAを利用しておりましたが、ファイルサイズが大きくなりすぎるので
自動で画像圧縮をさせたく。

こちらを参考にしましたが
 
 http://www.excel.studio-kazu.jp/kw/20150525120558.html

前半部分をダブルクリックで挿入、センターに設置
後半部分に
Sub 図の圧縮3(sp As Shape)を合体させればよいかと試しましたが判らず・・・

御教示下さい。

使用中のコードは下記です。

Option Explicit '変数宣言を強制

  Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

    Dim PicFile As Variant
    Dim rX As Double, rY As Double

    '[ファイルを開く]ダイアログボックスを表示
    PicFile = Application.GetOpenFilename( _
                        "画像ファイル,*.jpg;*.jpeg;*.gif;*.tif;*.png;*.bmp")
    If VarType(PicFile) = vbBoolean Then Cancel = True: Exit Sub

    Application.ScreenUpdating = False

  '画像を挿入
    With ActiveSheet.Pictures.Insert(PicFile)
        rX = Target.Width / .Width
        rY = Target.Height / .Height
        If rX > rY Then
            .Height = .Height * rY
        Else
            .Width = .Width * rX
        End If

  'セルの中央(横方向/縦方向の中央)に配置
        .Left = Target.Left + (Target.Width - .Width) / 2
        .Top = Target.Top + (Target.Height - .Height) / 2
    End With

    Application.ScreenUpdating = True
    Cancel = True

End Sub

VBAを理解しておらず、申し訳ございません。。

< 使用 Excel:Excel2010、使用 OS:Windows7 >


 別のトピですが

[[20151106133015]] 『画像貼り付けコードの応用』(もやし)

 この中で (β) 2015/11/07(土) 12:32 に、セル領域の 95% に合わせるコードをアップしました。
 当該領域の100%であれば、このコードの中の * 0.95 (3か所) をなくします。

 ご参考まで。
(β) 2015/11/17(火) 20:02

試していませんが、合体させるとすると、こんな感じです。

    .Cut
End With
Me.PasteSpecial Format:="図 (JPEG)"
With Shapes(Shapes.Count)
    'セルの中央(横方向/縦方向の中央)に配置
    .Left = Target.Left + (Target.Width - .Width) / 2
    .Top = Target.Top + (Target.Height - .Height) / 2
End With

(マナ) 2015/11/17(火) 20:51


β様
回答ありがとうございます。参考にさせて貰います。
 →セルに対してのサイズが変わり、画像ファイルの容量が変わらないような気がします。
  

マナ様
回答ありがとうございます。記載いただいたコードを追記すると、望んでいた動作になりました!
ダブルクリックで挿入した画像が一旦Cutされ、Jpeg形式で貼り付けられ(ファイル容量が減り)
指定セルに上下センタリングで配置されました。

今回、質問するに当たり新規のBookでコードを書き合体分をご教示いただいたのですが
実際に使用しているファイルへ上記のコードを追記すると、Cutし貼り付けまでは動作しますが
上下センタリングにはなりません・・・
何故でしょうか。

下記に現在のコード全文を記載します。 お時間あればご教示ください。
 →本来 Option Explicit を記載しないとダメなのですが、記載するとエラーだらけで
  動かなくなったので、外しています。申し訳ありません。
   →下から7行目”.Left = .Left + (myRange・・・”で停止します。

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean)

    Dim myPic As Variant
    Dim mySp As Object
    Dim rX As Double, rY As Double

 '写真挿入のセルを指定

    If Application.Intersect(Target, Range("d6,d23,d40,d58,d75,d92")) Is Nothing Then Exit Sub

    Cancel = True

    Application.ScreenUpdating = False

 '「選択セル範囲に」「完全に含まれている」画像を削除

  '選択範囲の開始座標、終了座標
     Dim x1 As Single
     Dim y1 As Single
     Dim x2 As Single
     Dim y2 As Single

  '選択範囲の開始座標、終了座標を設定
     x1 = Selection.Left
     y1 = Selection.Top
     x2 = x1 + Selection.Width
     y2 = y1 + Selection.Height

     Dim MyOb As Object
     For Each MyOb In ActiveSheet.Pictures

  '画像を削除
     If MyOb.Left >= x1 And _
     MyOb.Top >= y1 And _
     MyOb.Left + MyOb.Width <= x2 And _
     MyOb.Top + MyOb.Height <= y2 Then

  'MsgBox ("画像を削除します。")
     MyOb.Delete

End If

  '写真挿入

Next

    myPic = Application.GetOpenFilename("画像ファイル,*.jpg;*.jpeg;*.gif;*.tif")

    If myPic = False Then
           MsgBox "画像を選択してください"

        Exit Sub

    End If

  '画像を挿入
    With ActiveSheet.Pictures.Insert(myPic)
        rX = Target.Width / .Width
        rY = Target.Height / .Height
        If rX > rY Then
            .Height = .Height * rY
        Else
            .Width = .Width * rX
 End If

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

       .Left = .Left + (myRange.Width - .Width) / 2 '写真を横方向の中央に配置
       .Top = .Top + (myRange.Height - .Height) / 2 '写真を縦方向に中央に配置 
       .ZOrder msoSendToBack  '最背面へ移動

End With

    Application.ScreenUpdating = True
    Cancel = True

End Sub
  

(Rin) 2015/11/17(火) 23:57


Option Explicitがあれば…という典型的な事例かと思います。

 最初は、
 >.Left = Target.Left + (Target.Width - .Width) / 2

  突然でてきたmyRangeって何?
 >.Left = .Left + (myRange.Width - .Width) / 2

 SEWING11 さんでしょうか?
 同じ質問をあちこちでして、混乱していませんか?

(マナ) 2015/11/18(水) 19:48


マナ様

回答ありがとうございます。
そうですね。。プチパニックです。
業務で必要なので焦ってます。が、焦っても解決しないので
1からゆっくり考えます。
ありがとうございました。
(Rin) 2015/11/18(水) 22:49


 >>焦っても解決しないので1からゆっくり考えます。

 そうされたらいいと思います。
 あちらでもコメントしましたが
 テーマとしての

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

 それに加えて、

 4.貼り付けた図をシート上で、別形式で貼り付けなおす(そうしたい意図はわかりませんが)

 もあるようですね。

 これらの、どれとどれは実現している、どれが実現していない。それを整理した上で
 その実現していない(実現したい)テーマに絞って質問をされたほうがいいですよ。
 1〜4、いずれも、機能的には、難しくもなんともないものですから。

 それと、画像圧縮ですけど、いろいろ方法はあるかと思いますが、貼り付けた図の縦横サイズを小さくするだけで
 エクセルとしてのファイルサイズは減少しますよ。

(β) 2015/11/19(木) 11:07


コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.