Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 10 Pro : Microsoft 365)
画像の圧縮
投稿日時: 22/07/27 09:18:59
投稿者: George

Georgeです。
 
早速ですが質問させていただきます。
 
シート上に貼り付けた画像に対して、Excelの機能である
【画像の圧縮】を使っているのですが、圧縮がうまくいかないものがあります。
 
下にソースを貼っておきます。
 

    Dim oneShp As Shape
    Dim pasteLeft As Double, pasteTop As Double

    For Each oneShp In ActiveSheet.Shapes
        If oneShp.Type = msoPicture Then
            oneShp.Select
            Application.SendKeys "%e~" '[電子メール用 (96 ppi)]を選択
            Application.CommandBars.ExecuteMso "PicturesCompress"
        End If
        Sleep 10
    Next

 
このソースだとマクロを動作させているExcelが最前面でないと
画像の圧縮ウインドウが出てしまいます。
他の方法で実装できるのであれば他の方法もご教授いただければと思います。
 
以上 よろしくお願いいたします。

回答
投稿日時: 22/07/27 11:34:23
投稿者: sk

引用:
シート上に貼り付けた画像

引用:
画像の圧縮

引用:
電子メール用 (96 ppi)

(標準モジュール)
--------------------------------------------------------------------
Option Explicit
 
Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
 
Sub CompressPictures()
     
    Dim wsIncludePictures As Worksheet
     
    Set wsIncludePictures = ActiveSheet
     
    If wsIncludePictures.Shapes.Count = 0 Then
        Set wsIncludePictures = Nothing
        Exit Sub
    End If
     
    Dim shpPicture As Shape
    Dim lngPictureCount As Long
    Dim aryPictureNames() As Variant
     
    lngPictureCount = 0
     
    For Each shpPicture In wsIncludePictures.Shapes
        If shpPicture.Type = msoPicture Then
            lngPictureCount = lngPictureCount + 1
            ReDim Preserve aryPictureNames(1 To lngPictureCount)
            aryPictureNames(lngPictureCount) = shpPicture.Name
        End If
    Next
     
    If lngPictureCount = 0 Then
        Set wsIncludePictures = Nothing
        Exit Sub
    End If
     
    Dim varPictureName As Variant
    Dim shpNewPicture As Shape
 
    For Each varPictureName In aryPictureNames
        Set shpPicture = wsIncludePictures.Shapes(varPictureName)
        shpPicture.Copy
        wsIncludePictures.PasteSpecial Format:="図 (JPEG)", Link:=False, DisplayAsIcon:=False
        Set shpNewPicture = wsIncludePictures.Shapes(wsIncludePictures.Shapes.Count)
        shpNewPicture.Left = shpPicture.Left
        shpNewPicture.Top = shpPicture.Top
        shpPicture.Delete
        Set shpPicture = Nothing
        shpNewPicture.Name = varPictureName
        Set shpNewPicture = Nothing
        Sleep 10
    Next
     
    Set wsIncludePictures = Nothing
 
End Sub
--------------------------------------------------------------------
 
以上のようなコードを実行できればよい、ということでしょうか。

投稿日時: 22/07/27 12:09:39
投稿者: George

skさん
 
早速の回答ありがとうございます。
実際に私が提示していたソースの部分と差し替えてやってみたところ

shpPicture.Copy

のところでエラーになることがありました。
 
引用:

<エラー内容>
実行時エラー '-2147221040(800401d0)'
'Copy'メソッドは失敗しました 'Shape' オブジェクト

 
デバッグボタンを押して進めると、また別のオブジェクトに対して
処理をしているところで同様のエラーが何度も出ます。
 
なにか私がマズいことをしているのでしょうか?

回答
投稿日時: 22/07/27 13:35:50
投稿者: sk

引用:
実行時エラー '-2147221040(800401d0)'
'Copy'メソッドは失敗しました 'Shape' オブジェクト

恐らく短時間にクリップボードへのコピーを繰り返しているため、
下記の現象が起こっているのでしょう。
 
MSDN より:
https://social.msdn.microsoft.com/Forums/ja-JP/edaf2154-6d21-47c2-9eef-12f66034b058/12463125221248312503125081254012489?forum=officesupportteamja
 
類似スレッド:
https://www.moug.net/faq/viewtopic.php?t=81498
 
引用:
shpPicture.Copy

強引にやるなら次のような感じになるかと。
 
----------------------------------------------------------
 
On Error Resume Next
Do
    Err.Clear
    shpPicture.Copy
Loop Until Err.Number = 0
On Error GoTo 0
 
----------------------------------------------------------

投稿日時: 22/07/27 14:51:33
投稿者: George

skさん、早速の回答ありがとうございます。
 

sk さんの引用:

引用:
shpPicture.Copy

強引にやるなら次のような感じになるかと。
 
----------------------------------------------------------
 
On Error Resume Next
Do
    Err.Clear
    shpPicture.Copy
Loop Until Err.Number = 0
On Error GoTo 0
 
----------------------------------------------------------

こちらに書き換えてやってみましたが、Loop Until Err.Number = 0のところに
ブレイクポイントを設定して動作したときにはErr.Numberが0になっていて
問題なく動くのですが、ブレイクポイントを設定せずに動かすと無限ループに入っているのか
応答なしになって先に進んでいないような感じでした。
 
他にもFor Eachステートメント内の処理をOn Error Resume Next〜On Error Goto 0で
囲んだのですが、それだと
shpPicture.Delete
の後でエラーが出るときがあったのか
画像が貼られない状態になった部分などがありました。
 
クリップボードへのコピーを短時間にやらないためにAPI関数のSleep()とかで
処理を入れてみても無限ループするような感じでうまくいきませんでした。
 

回答
投稿日時: 22/07/27 16:29:42
投稿者: sk

引用:
こちらに書き換えてやってみましたが、Loop Until Err.Number = 0のところに
ブレイクポイントを設定して動作したときにはErr.Numberが0になっていて
問題なく動くのですが、ブレイクポイントを設定せずに動かすと無限ループに入っているのか
応答なしになって先に進んでいないような感じでした。

クリップボードのロックの仕組み上、コピーするデータのサイズが大きければ
その分ロック時間も長くなりますし、またコピーする回数が増えれば増えるほど
競合が発生しやすくなります。
 
もしそのワークシート上にサイズの大きな画像が大量に配置されているのであれば、
それは起こるべくして起こっている現象なのではないかと。
 
また、実行環境に常駐しているセキュリティ対策ソフトがクリップボードを
監視しているのであれば、より競合しやすくなると思われます。
 
引用:
クリップボードへのコピーを短時間にやらないためにAPI関数のSleep()とかで
処理を入れてみても無限ループするような感じでうまくいきませんでした。

とりあえず無限ループに陥らないようにするには、コピーの再試行回数や
タイムアウトの条件を設けるようにすることが考えられます。
 
---------------------------------------------------------------------
Option Explicit
 
Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
 
Sub CompressPictures()
     
    Dim wsIncludePictures As Worksheet
     
    Set wsIncludePictures = ActiveSheet
     
    If wsIncludePictures.Shapes.Count = 0 Then
        Set wsIncludePictures = Nothing
        Exit Sub
    End If
     
    Dim shpPicture As Shape
    Dim lngPictureCount As Long
    Dim aryPictureNames() As Variant
     
    lngPictureCount = 0
     
    For Each shpPicture In wsIncludePictures.Shapes
        If shpPicture.Type = msoPicture Then
            lngPictureCount = lngPictureCount + 1
            ReDim Preserve aryPictureNames(1 To lngPictureCount)
            aryPictureNames(lngPictureCount) = shpPicture.Name
        End If
    Next
     
    If lngPictureCount = 0 Then
        Set wsIncludePictures = Nothing
        Exit Sub
    End If
     
    Dim varPictureName As Variant
    Dim shpNewPicture As Shape
    Dim lngRetryCount As Long

    For Each varPictureName In aryPictureNames
         
        Set shpPicture = wsIncludePictures.Shapes(varPictureName)
        lngRetryCount = 0
         
        On Error Resume Next
        Do
            Err.Clear
            shpPicture.Copy
            If Err.Number <> 0 Then
                'とりあえず2秒待ってみる
                Sleep 2000
                '再試行カウンタを増やす
                lngRetryCount = lngRetryCount + 1
            End If
            '10回再試行してもダメなら終了する
            If lngRetryCount > 10 Then
                MsgBox "図[" & shpPicture.Name & "]をクリップボードにコピーできませんでした。処理を中断します。", _
                       vbCritical, _
                       "エラー"
                Set shpPicture = Nothing
                Set wsIncludePictures = Nothing
                Exit Sub
            End If
        Loop Until Err.Number = 0
        On Error GoTo 0
         
        wsIncludePictures.PasteSpecial Format:="図 (JPEG)", Link:=False, DisplayAsIcon:=False
        '念のため 0.5 秒待つ
        Sleep 500
         Set shpNewPicture = wsIncludePictures.Shapes(wsIncludePictures.Shapes.Count)
        shpNewPicture.Left = shpPicture.Left
        shpNewPicture.Top = shpPicture.Top
        shpPicture.Delete
        Set shpPicture = Nothing
        shpNewPicture.Name = varPictureName
        Set shpNewPicture = Nothing
   Next
     
    Set wsIncludePictures = Nothing
 
End Sub
---------------------------------------------------------------------

投稿日時: 22/08/01 14:41:54
投稿者: George

skさん
 
回答いただきありがとうございます。
返信が遅くなり申し訳ありません。
 
今朝から改めて動作させてみているのですが、なぜか圧縮前にはあった画像が
圧縮後にいなくなるような状況が出てきてしまっています。
 
ブレイクポイントを設定して動作させたり、ブレイクポイントを解除して動作させるのですが、
上記のような現象が出てしまいます。
 
また、最後に提示いただいたソースを採用して動作確認したところ
10回以上ダメだったのか回数エラーで終わる画像がありました。
 
さすがにこれを回避する方法はないのでしょうか?

回答
投稿日時: 22/08/03 11:13:21
投稿者: sk

引用:
今朝から改めて動作させてみているのですが、なぜか圧縮前にはあった画像が
圧縮後にいなくなるような状況が出てきてしまっています。

「いなくなる」というのが具体的にどのような状態を意味するのかが
不明ですが、今のところ考えられる原因としては、
 
引用:
wsIncludePictures.PasteSpecial Format:="図 (JPEG)", Link:=False, DisplayAsIcon:=False

上記の PasteSpecial メソッドによる図形の貼り付けにより
 
引用:
Set shpNewPicture = wsIncludePictures.Shapes(wsIncludePictures.Shapes.Count)

ワークシート内の図形の個数が 1 増えるはずが、図形の貼り付け
(それに伴う画像の JPEG 化処理)に時間がかかっているためか
正常に同期できておらず、貼り付け前の個数を取得してしまっている
ことが考えられます。
 
引用:
shpNewPicture.Left = shpPicture.Left
shpNewPicture.Top = shpPicture.Top
shpPicture.Delete
Set shpPicture = Nothing
shpNewPicture.Name = varPictureName

その場合、位置と名前を変更する対象が別の図形になってしまう恐れがあります。
 
(標準モジュール)
------------------------------------------------------------------------
Option Explicit
 
Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
 
Sub CompressPictures()
     
    Dim wsIncludePictures As Worksheet
     
    Set wsIncludePictures = ActiveSheet
     
    If wsIncludePictures.Shapes.Count = 0 Then
        Set wsIncludePictures = Nothing
        Exit Sub
    End If
     
    Dim shpPicture As Shape
    Dim lngPictureCount As Long
    Dim aryPictureNames() As Variant
     
    lngPictureCount = 0
     
    For Each shpPicture In wsIncludePictures.Shapes
        If shpPicture.Type = msoPicture Then
            lngPictureCount = lngPictureCount + 1
            ReDim Preserve aryPictureNames(1 To lngPictureCount)
            aryPictureNames(lngPictureCount) = shpPicture.Name
        End If
    Next
     
    If lngPictureCount = 0 Then
        Set wsIncludePictures = Nothing
        Exit Sub
    End If
     
    Dim varPictureName As Variant
    Dim shpNewPicture As Shape
    Dim lngRetryCount As Long
    Dim lngShapesCount As Long
 
    For Each varPictureName In aryPictureNames
         
        Debug.Print varPictureName
        Set shpPicture = wsIncludePictures.Shapes(varPictureName)
        lngRetryCount = 0
         
        '現時点での図形の個数を取得しておく
        lngShapesCount = wsIncludePictures.Shapes.Count
         
        On Error Resume Next
        Do
            Err.Clear
            shpPicture.Copy
            If Err.Number <> 0 Then
                '実行時エラーの内容をイミディエイトウィンドウに出力する
                Debug.Print Err.Number & ": " & Err.Description
                'とりあえず3秒待ってみる
                DoEvents
                Sleep 3000
                '再試行カウンタを増やす
                lngRetryCount = lngRetryCount + 1
            End If
            '10回再試行してもダメなら終了する
            If lngRetryCount > 10 Then
                MsgBox "図[" & shpPicture.Name & "]をクリップボードにコピーできませんでした。処理を中断します。", _
                       vbCritical, _
                       "エラー"
                Set shpPicture = Nothing
                Set wsIncludePictures = Nothing
                Exit Sub
            End If
        Loop Until Err.Number = 0
        On Error GoTo 0
         
        'クリップボードにコピーした図形をJPEG画像として貼り付け
        wsIncludePictures.PasteSpecial Format:="図 (JPEG)", Link:=False, DisplayAsIcon:=False
         
        lngRetryCount = 0
        '図形の個数が増えたのを確認できるまでループ
        Do Until wsIncludePictures.Shapes.Count > lngShapesCount
            '再試行カウンタを増やす
            lngRetryCount = lngRetryCount + 1
            '10回再試行してもダメなら終了する
            If lngRetryCount > 10 Then
                MsgBox "図[" & shpPicture.Name & "]の貼り付けの完了を確認できませんでした。処理を中断します。", _
                       vbCritical, _
                       "エラー"
                Set shpPicture = Nothing
                Set wsIncludePictures = Nothing
                Exit Sub
            End If
            'とりあえず3秒待ってみる
            DoEvents
            Sleep 3000
        Loop
         
        '追加された図形(貼り付けられた画像)を参照する
        Set shpNewPicture = wsIncludePictures.Shapes(wsIncludePictures.Shapes.Count)
        shpNewPicture.Left = shpPicture.Left
        shpNewPicture.Top = shpPicture.Top
        shpPicture.Delete
        Set shpPicture = Nothing
        shpNewPicture.Name = varPictureName
        Set shpNewPicture = Nothing
   Next
     
    Set wsIncludePictures = Nothing
 
End Sub
------------------------------------------------------------------------
 
改良するなら以上のような感じでしょうか。
 
引用:
また、最後に提示いただいたソースを採用して動作確認したところ
10回以上ダメだったのか回数エラーで終わる画像がありました。

もし特定の画像でのみ必ずコピーに失敗してしまうのであれば、
とりあえず手動操作によってその画像の圧縮やコピーアンドペースト
(形式を選択して貼り付け)が可能であるか、その処理にどれだけ
時間が掛かるかなどを確認されることをお奨めします。

投稿日時: 22/08/03 14:51:47
投稿者: George

skさん
ありがとうございます。
最後に提示いただいたソースをほぼ採用して動作させたところ
思い通りの動作をすることが出来ました。
 

引用:
もし特定の画像でのみ必ずコピーに失敗してしまうのであれば、
とりあえず手動操作によってその画像の圧縮やコピーアンドペースト
(形式を選択して貼り付け)が可能であるか、その処理にどれだけ
時間が掛かるかなどを確認されることをお奨めします。

今回はこれにてクローズとしますが、同じマクロ内で他の事象などあった場合は
これを肝に銘じて進めていきたいと思います。[/quote]