[[20240409123643]]　『トリミング（切り出し）part2』（joy）　ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) |

| 全文検索 | 過去ログ ]

『トリミング（切り出し）part2』（joy）

改めて、質問し直します。

コード中の下記コードエラーが出ます。
With ActiveSheet.Pictures.Insert(file.Name)

実行エラー：1004　「pictures クラスの Insert プロパティを取得できません。」

ローカルウィンドウでチェックすると
　file.Name の値が正確に「C:\Users\TAC_\test\2test.jpg」と表示されていました。

コードの修正をしたいのですが、なぜエラーが出て修正はどうすべきですか　？

Sub TrimAndSaveImages()

      Dim folderPath As String
      Dim NewWidth As Long
      Dim NewHeight As Long
      Dim fso As Object
      Dim folder As Object
      Dim file As Object
      Dim img As Object
      Dim NewFilePath As String
      Dim LeftOffset As Long
      Dim flag As Long

      ' フォルダパス
      folderPath = "C:\Users\TAC_\test\"

      ' フォルダ内のファイルを取得
      Set fso = CreateObject("Scripting.FileSystemObject")
      Set folder = fso.GetFolder(folderPath)

      ' 各ファイルに対してトリミングを実行
      For Each file In folder.Files
            If LCase(Right(file.Name, 4)) = ".jpg" Or LCase(Right(file.Name, 5)) = ".jpeg" Then

                  'ファイルの先頭にどんな処理をすべきかのFLAGマーク有り
                  flag = Left(file.Name, 1)

                  Set img = CreateObject("WIA.ImageFile")
                  img.LoadFile file.Path

                  Select Case flag
                        Case 1
                             ' ----- 省略 -----
                        Case 2

                                    ' トリミング後のサイズを指定 (ピクセル単位)
                                    NewWidth = (img.height + img.Width) / 2
                                    NewHeight = (img.height + img.Width) / 2

                                    ' 新しいファイル名を指定
                                    NewFilePath = folderPath & fso.GetBaseName(file.Name) & "(new)." & fso.GetExtensionName(file.Name)

                                    ' 画像をトリミング
                                    With ActiveSheet.Pictures.Insert(file.Name)
                                          .ShapeRange.LockAspectRatio = msoFalse
                                          .ShapeRange.Width = NewWidth
                                          .ShapeRange.height = NewHeight
                                    End With

                                    ' 画像を新しいファイル名で保存
                                    ActiveSheet.Shapes(ActiveSheet.Shapes.Count).Copy
                                    With New Workbook
                                          .Sheets(1).Paste
                                          .SaveAs NewFilePath
                                          .Close SaveChanges:=False
                                    End With

                  End Select
            End If
      Next file

      MsgBox "トリミングが完了しました。"
End Sub

＜使用 Excel：Excel2021、使用 OS：Windows11 ＞

 >ローカルウィンドウでチェックすると
 >file.Name の値が正確に 「C:\Users\TAC_\test\2test.jpg」と表示されていました。
 いいえ、Nameプロパティはファイル名のみです。
 Pictures.Insertはフルパスで指定する必要があるので、File.Pathを使う必要があります。
（´・ω・`） 2024/04/09(火) 13:24:05

  >いいえ、Nameプロパティはファイル名のみです。
 >Pictures.Insertはフルパスで指定する必要があるので、File.Pathを使う必要があります。

 すいません。
 見てるつもりで.Nameと.pathを間違えて認識していました。
 助言でエラーは無くなったのですが毎回画像をシートに書き出すのは違うかなと思って
 case1のコードをトレースする形式に変更しました。

 エラーなく処理されているようです。
 お騒がせしました。

                      Case 2
                              ' 新しい画像サイズ
                              NewWidth = (img.height + img.Width) / 2
                              NewHeight = (img.height + img.Width) / 2
                              NewFilePath = folderPath & fso.GetBaseName(file.Name) & "(new)." & fso.GetExtensionName(file.Name)
                              ' 画像サイズを指定して新規に画像を作成
                              With CreateObject("WIA.ImageProcess")
                                    .Filters.Add .FilterInfos("Scale").FilterID
                                    .Filters(1).Properties("MaximumWidth") = NewWidth
                                    .Filters(1).Properties("MaximumHeight") = NewHeight
                                    .Filters(1).Properties("PreserveAspectRatio") = False      'false : アスペクト比は維持しない
                                    '画像保存
                                    .Apply(img).SaveFile NewFilePath
                              End With
                  End Select
（joy） 2024/04/09(火) 15:15:07

コメント返信：

[ 一覧(最新更新順) ]

[[20240409123643]] 『トリミング（切り出し）part2』（joy） ページの最後に飛ぶ

[[20240409123643]]　『トリミング（切り出し）part2』（joy）　ページの最後に飛ぶ