Results of 1 - 1 of about 33507 for 関数 (0.006 sec.)
- [[20240408122016]]
- #score: 2647
- @digest: cc6a70296e2d1dd975152e4982c084b9
- @id: 96566
- @mdate: 2024-04-09T13:43:35Z
- @size: 9360
- @type: text/plain
- #keywords: leftoffset (56859), savepicture (46660), newfilepath (45246), targetheight (44989), targetwidth (44285), imagefile (33435), picbox (29523), リミ (22969), 順← (22862), wiaif (21804), ipicturedisp (19788), imageprocess (18382), filters (16890), loadfile (16399), folderpath (14927), trimmed (14647), acquisition (13013), savefile (12797), img (10629), wia (10447), 成ne (10401), properties (7792), トリ (6747), longptr (6660), ミン (5624), file (4941), 行fo (4041), folder (3909), lcase (3240), ング (3186), picture (3115), 白茶 (3078)
- 『トリミング（切り出し）
』（joy） EXCELのVBAでファオルダー内の複数画像(JPEG)を指定サイズで一括トリミング（切り出し）して 同名で保存するようにしたいです。 例えば、1280x720をトリミングする場合 左上角の座標 280,0 ＜----（1280-720)/2=280 サイズ 720x720 （正方形）＜-------- オリジナルの縦サイズ アスペクト比は維持しない コードを考えていますが、トリミングをどうするのかで止まっています。 サンプルコードをお願いできないでしょうか ? Sub TrimAndSaveImages() Dim folderPath As String Dim targetWidth As Long Dim targetHeight 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 ' フォルダパス folderPath = "C:¥Users¥TAC_¥test¥" '参照＞ 「Microsoft Scripting Runtime」 '以下は、参照設定を使わない方法 ' フォルダ内のファイルを取得 Set fso = CreateObject("Scripting.FileSystemObject") Set folder = fso.GetFolder(folderPath) '参照＞「Microsoft Windows Image Acquisition Library 2.0」 ' 各ファイルに対してトリミングを実行 For Each file In folder.Files If LCase(Right(file.Name, 4)) = ".jpg" Or LCase(Right(file.Name, 5)) = ".jpeg" Then Set img = CreateObject("WIA.ImageFile") img.LoadFile file.Path targetWidth = img.Width targetHeight = img.Height leftOffset = (img.Width - img.Height) / 2 ' トリミング ' 新しいファイルパスを作成 newFilePath = folderPath & "Trimmed_" & file.Name ' トリミングした画像を保存 End If Next file MsgBox "トリミングが完了しました。" End Sub ＜ 使用 Excel:Excel2021、使用 OS:Windows11 ＞ ---- 勘で... ' トリミング With CreateObject("WIA.ImageProcess") .Filters.Add .FilterInfos("Crop").FilterID .Filters(1).Properties("Left") = leftOffset .Filters(1).Properties("Right") = leftOffset ' 新しいファイルパスを作成 newFilePath = folderPath & "Trimmed_" & file.Name ' トリミングした画像を保存 Apply(img).SaveFile newFilePath End With （白茶） 2024/04/08(月) 15:16:06 ---- ありがとうございます。 コードで目的の事できました。 applyの前に「.」が無かったので追加しました。 .Apply(img).SaveFile newFilePath '----- （joy） 2024/04/08(月) 16:22:52 ---- あらら。失礼しやした。^^; ちなみにGDI+を直に使う場合は「GdipDrawImageRectRectI」ってのでイケそうな感じでした。(色調補正に使ったりするヤツですね〜) Private Enum GpUnit UnitWorld = 0 UnitDisplay = 1 UnitPixel = 2 UnitPoint = 3 UnitInch = 4 UnitDocument = 5 UnitMillimeter = 6 End Enum Private Declare PtrSafe Function GdipDrawImageRectRectI Lib "gdiplus" (ByVal graphics As LongPtr, ByVal image As LongPtr, _ ByVal dstX As Long, ByVal dstY As Long, ByVal dstWidth As Long, ByVal dstHeight As Long, _ ByVal srcx As Long, ByVal srcy As Long, ByVal srcwidth As Long, ByVal srcheight As Long, ByVal srcUnit As GpUnit, _ Optional ByVal imageAttributes As LongPtr = 0, Optional ByVal callback As LongPtr = 0, Optional ByVal callbackData As LongPtr = 0) As Long （白茶） 2024/04/08(月) 16:50:56 ---- その後、コードを改変中ですが Case 2の保存でエラーがでます。 修正をお願いできますか ? Sub TrimAndSaveImages() Dim folderPath As String Dim targetWidth As Long Dim targetHeight 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 topOffset As Long Dim flag As Long ' フォルダパス folderPath = "C:¥Users¥TAC_¥test¥" ' '参照＞ 「Microsoft Scripting Runtime」 '以下は、参照設定を使わない方法 ' フォルダ内のファイルを取得 Set fso = CreateObject("Scripting.FileSystemObject") Set folder = fso.GetFolder(folderPath) '参照＞「Microsoft Windows Image Acquisition Library 2.0」 ' 各ファイルに対してトリミングを実行 For Each file In folder.Files If LCase(Right(file.Name, 4)) = ".jpg" Or LCase(Right(file.Name, 5)) = ".jpeg" Then '画像ファイルのパターンで区別 flag = Left(file.Name, 1) Set img = CreateObject("WIA.ImageFile") img.LoadFile file.Path Select Case flag Case 1 targetWidth = img.height targetHeight = img.height leftOffset = (img.Width - img.height) / 2 ' トリミング With CreateObject("WIA.ImageProcess") .Filters.Add .FilterInfos("Crop").FilterID .Filters(1).Properties("Left") = leftOffset .Filters(1).Properties("Right") = leftOffset ' 新しいファイルパスを作成 (ファイル名の最後に(new)を追加） newFilePath = folderPath & fso.GetBaseName(file.Name) & "(new)." & fso.GetExtensionName(file.Name) ' トリミングした画像を保存 .Apply(img).SaveFile newFilePath End With Case 2 targetWidth = (img.height + img.widt) / 2 targetHeight = (img.height + img.widt) / 2 Dim picBox As Object Set picBox = CreateObject("Scripting.Dictionary") picBox.Add "Picture", img picBox.Add "Width", targetWidth picBox.Add "Height", targetHeight '保存 SavePicture picBox("Picture"), folderPath & fso.GetBaseName(file.Name) & "(new)." & fso.GetExtensionName(file.Name) End Select End If Next file MsgBox "トリミングが完了しました。" End Sub （joy） 2024/04/09(火) 06:25:54 ---- ＞Case 2の保存でエラーがでます。 エラー名を書きましょう。 （えらー） 2024/04/09(火) 11:54:53 ---- ご迷惑をおかけしました。 Case2 のコードを全面的に見直し中なので 質問自体をCANCELとしたいので、これ以上の回答は必要ありません。 （joy） 2024/04/09(火) 12:16:17 ---- >これ以上の回答は必要ありません。 との事ですが、 後からここを訪れる人々の為にサラッとだけ書いておきますと... SavePictureで画像をファイル保存するには[IPictureDisp]を引数に指定しないと型エラーになります。 Dictionaryに登録しようとも元々[ImageFile]でしかありませんので、SavePictureは使えません。 どうしてもSavePictureを使いたいのなら、何とかして[ImageFile]から[IPictureDisp]を作る必要があります。 (出来ない事は無いとは思いますが、ちょっと複雑で面倒な手順になるでしょね) まあ画像をファイル保存のが目的なら、わざにここでSavePictureを使う必要もありませんし。 ちなみに、SavePictureで保存されたjpgファイルは、 「いや、だったらbmpでいいよ」って結果になる事が多々ありますので、私は好んで使おうとは思いません。 （白茶） 2024/04/09(火) 14:26:27 ---- あ。あと （白茶） 2024/04/08(月) 16:50:56 の発言は [[20240330113454]]の続きだと解釈しての発言です。 今読み返してみたら自分でも「なんのこっちゃ?」って思ったので補足。^^; （白茶） 2024/04/09(火) 14:26:55 ---- おやおや〜? ちょっとぉ〜? こwwwれwwwはwww 恥かしい事態判明。^^; >> どうしてもSavePictureを使いたいのなら、何とかして[ImageFile]から[IPictureDisp]を作る必要があります。 >> (出来ない事は無いとは思いますが、ちょっと複雑で面倒な手順になるでしょね) >> 複雑で面倒な手順 ← >> 複雑で面倒な手順 ← >> 複雑で面倒な手順 ← いやいやいや、全っっっっ然簡単な話やったで。もうびっくりですわ。orz Dim wiaIF As New WIA.ImageFile, p As IPictureDisp wiaIF.LoadFile "C:¥xxx¥test1.jpg" Set p = wiaIF.ARGBData.Picture(wiaIF.Width, wiaIF.Height) SavePicture p, "C:¥xxx¥test2.jpg" WIAスゲーっすね。 ImageProcessのFilter達も、GDI+グラフィックス関数の呼び出し簡素化っぽい構成で なんか色々とハードル下げてくれるっぽいです。 地味に優秀w How to Use Filters | Microsoft Learn https://learn.microsoft.com/en-us/previous-versions/windows/desktop/wiaaut/-wiaaut-howto-use-filters てか、何せ情報乏しい... （白茶） 2024/04/09(火) 22:43:35
... - http://www.excel.studio-kazu.jp/wiki/kazuwiki/202404/20240408122016.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97034 documents and 608020 words.
訪問者：