[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『ペイントを開いて伸縮と傾きを変更』（あや）
●やりたいこと
フォルダに入ったJPGファイルの画像の大きさを変更させたく
複数のJPGファイルがあるため、マクロで自動化したい
●かんがえたこと
JPGファイルをペイントで開いて、
[変形]-[伸縮と傾き]を指定する
（指定サイズはセルに入力して変数で渡すか
フォームのテキストボックスに入力を求めるかにします）
●つくりかけているもの
Option Explicit
Sub SubStart()
Dim StrFPath As String
Dim Fbuf As String
Application.ScreenUpdating = False
StrFPath = Sheet3.Lblフォルダ指定.Caption
Fbuf = StrFPath & "\" & Dir(StrFPath & "\" & "*")
Do While Fbuf <> StrFPath & "\"
Open Fbuf For Input As #1
☆画像が開いてきません
Fbuf = StrFPath & "\" & Dir()
Loop
Application.ScreenUpdating = True
End Sub
●問題
☆のところで、画像が開いてきておらず
2回目のLoppに入ってから
Open Fbuf For Input As #1のところで
「実行時エラー 55 ファイルは既に開かれています」となります
なにがどのようにできるのかわからずにもやもやしながら作っていて
ペイントで開けたらSendkeysを使おうかなと考えていたりするのですが…
半端な感じの質問になってしまい、すみません。
根本的にもっと別の方法があるよ、などもありましたら教えてください
＜ 使用 Excel：Excel2013、使用 OS：WindowsXP ＞
縮小専用。 http://i-section.net/software/shukusen/
こういうソフトがフリーでありますが、足りないですか？ （稲葉） 2014/01/08(水) 11:12
会社内での作業になるのですが
社内にフリーソフトが入れられないため
VBAの対応を考えております
（あや） 2014/01/08(水) 11:17
表示だけ小さくするならば、解像度情報だけバイナリ変更すれば、画素数は
そのままで、見た目だけ小さくする方法が使えます。
ファイルサイズ自体を小さくするならば、ActiveSheet.Pictures.Insertを使って
シート上に画像貼付け後、拡大率を変更（Excel上で縮小してしまう）、コピー、
クリップボード経由でペイント等で保存、とかでしょうか。
ペイントブラシ操作が面倒であれば、画像縮小後にWebページ(html)として保存し、
出力されたファイルの中から画像を拾う、とか？
（???） 2014/01/08(水) 11:42
こんにちは。
WIAの機能を使用してはどうでしょうか。
Function ImgScaleChange( _
ByVal LoadFile As String, _
ByVal SaveFile As String, _
ByVal MaxWidth As Long, _
ByVal MaxHeight As Long) As Boolean
Dim Img As Object Dim IP As Object
Set Img = CreateObject("WIA.ImageFile")
Set IP = CreateObject("WIA.ImageProcess")
If Len(Dir(LoadFile)) <> 0 And Len(Dir(SaveFile)) = 0 Then
Img.LoadFile LoadFile
IP.Filters.Add IP.FilterInfos("Scale").FilterID
IP.Filters(1).Properties("MaximumWidth") = MaxWidth
IP.Filters(1).Properties("MaximumHeight") = MaxHeight
Set Img = IP.Apply(Img)
Img.SaveFile SaveFile
ImgScaleChange = True
End If
Set IP = Nothing Set Img = Nothing End Function
MaxiWidthとMaxHeightに指定した値の範囲内で縦横の比が保持された画像が作成されます。 上書き保存はできません。
（ちび坊主） 2014/01/08(水) 14:03
???さんありがとうございます
見た目のサイズとファイルサイズも小さくしようと思っています。
ちび坊主さんに教えて頂いた方法をためしてみました。
Private Sub CmdStart_Click()
Fpass1 = "C:\画像フォルダ\1無題.JPG"
Fpass2 = "C:\画像フォルダ\1無題2.JPG"
Call ImgScaleChange(Fpass1, Fpass2, 10, 10)
End Sub
Function ImgScaleChange( _
ByVal LoadFile As String, _
ByVal SaveFile As String, _
ByVal MaxWidth As Long, _
ByVal MaxHeight As Long) As Boolean
Dim Img As Object Dim IP As Object
Set Img = CreateObject("WIA.ImageFile") ☆
Set IP = CreateObject("WIA.ImageProcess")
（省略）
End Function
☆のところで
「実行時エラー429 ActiveXコンポーネントはオブジェクトを作成できません」
となります。
ファイルのパスは間違っていないのです
確認方法や試してみたらよいことなどありましたら教えてください。
（あや） 2014/01/08(水) 15:59
こっちも地道に調べて作ってみた。 １、図の挿入で、一括処理したい図を一つのシートに貼り付ける ２、図が挿入されているシートを選択して、サイズ変更を実行する ３、図を挿入したブックの保存先に裸で「jpeg」の画像だけ出力される
'==ここから
Option Explicit
Dim Target As String
Dim colItem As New Collection
Sub サイズ変更()
Dim W As Integer
Dim objSP As Shape
Dim strZIP As String
On Error Resume Next
W = CInt(InputBox("変更したいサイズの横幅を入力してください", , 640))
If Err > 0 Then MsgBox ("数値で入力してください"): Exit Sub
On Error GoTo 0
For Each objSP In ActiveSheet.Shapes
With objSP
.LockAspectRatio = True
.Width = W
.Cut
End With
ActiveSheet.PasteSpecial Format:="図 (JPEG)"
Next
strZIP = ThisWorkbook.Path & "\test.zip"
ThisWorkbook.SaveCopyAs strZIP
Target = "jpeg"
Call 画像取得(strZIP, ThisWorkbook.Path & "\")
MsgBox ("画像をこのブックの保存先に保存しました。")
End Sub
Sub 画像取得(ByVal strGetPath As Variant, ByVal strOutPath As Variant)
Dim objFolder
Dim c As Object
Target = "jpeg"
With CreateObject("Shell.Application")
Set objFolder = .Namespace(strGetPath)
Call GETZIP(objFolder.Items())
Set objFolder = .Namespace(strOutPath)
For Each c In colItem
objFolder.CopyHere c
Next
End With
Set objFolder = Nothing
End Sub
Sub GETZIP(tmpF)
Dim tmpI As Object
For Each tmpI In tmpF
With tmpI
If tmpI.IsFolder Then
Call GETZIP(tmpI.GetFolder.Items())
Else
If tmpI.Name Like "*" & Target Then
colItem.Add tmpI
End If
End If
End With
Next
End Sub
'==ここまで
この場を借りて質問・・・ Shell.ApplicationのNameSpaceで、String型の変数で値を渡すと、Nothingになってしまいました。 変数の型をVariantにして引数を渡すと大丈夫だったのですが、Shell.Applicationに渡す型はVariant じゃないとだめなんですかね？
（稲葉） 2014/01/08(水) 16:35
参照設定で、Microsoft Windows Acquisition Libraryはあるでしょうか。 これがなければ、WIAがインストールされてない恐れがあります。 その場合は、この手法はあきらめてください。
あれば、参照設定でチェックを入れて、CreateObjectの代わりに、Newキーワードで
Set Img = New WIA.ImageFile Set IP = New WIA.ImageProcess
としてみてはどうでしょうか。 （ちび坊主） 2014/01/08(水) 16:42
なお、ダウンロードするURLリンクが切れていたので、いまはどれをインストールするのか判らず。
ドライバ開発SDK等を入れないと駄目なのだろうか？ それはちょっと…。
（私の使っているXPには入っているので、何かのついでにインストールされる模様）
（???） 2014/01/08(水) 17:03
稲葉さん ちび坊主さん ???さんありがとうございます
ちび坊主さん???さんの教えてくださった Microsoft Windows Acquisition Library が見当たらないため…;д;
今現在、稲葉さんの方法で進めさせていただいております
（挿入-図-ファイルから で図の挿入をしなくても良いように フォルダを指定するよう付け加えました）
Option Explicit Dim Target As String Dim colItem As New Collection
Public Sub Subサイズ変更()
Dim W As Integer
Dim objSP As Shape
Dim strZIP As String
On Error Resume Next
Dim StrFPath As String
Dim Fbuf As String
W = CInt(InputBox("変更したいサイズの横幅を入力してください", , 640))
If Err > 0 Then MsgBox ("数値で入力してください"): Exit Sub
On Error GoTo 0
Application.ScreenUpdating = False
StrFPath = Sheet3.Lblフォルダ指定.Caption
Fbuf = StrFPath & "\" & Dir(StrFPath & "\" & "*")
Do While Fbuf <> StrFPath & "\"
ActiveSheet.Pictures.Insert(Fbuf).Select
For Each objSP In ActiveSheet.Shapes
With objSP
.LockAspectRatio = True '指定した図形のサイズを変更しても元の比率が保持される
.Width = W
.Cut
End With
ActiveSheet.PasteSpecial Format:="図 (JPEG)"
Next
Fbuf = StrFPath & "\" & Dir()
Loop
strZIP = ThisWorkbook.Path & "\test.zip"
ThisWorkbook.SaveCopyAs strZIP
Target = "jpeg"
Call 画像取得(strZIP, ThisWorkbook.Path & "\")
MsgBox ("画像をこのブックの保存先に保存しました。")
Application.ScreenUpdating = True
End Sub
おかげさまで このプログラムで最後まで進めるのですが 保存できたZIPをダブルクリックすると 「圧縮（zip形式）フォルダは無効であるか、または壊れています」となり 開けることができません。
strZIP = ThisWorkbook.Path & "\test.zip"
の部分にブレークポイントを置いてデバッグをすると
「中断モードでは入力できません」と出てしまい
どのように確認・対処すればよいかわからなくなっています。
なんどもすみませんが、アドバイスよろしくおねがいします。
（あや） 2014/01/09(木) 11:14
横から失礼しますが、 ThisWorkbook.SaveCopyAs strZIP は無茶な気がします。
EXCEL は ZIP フォーマットで保存できませんので、いったん通常のファイル形式で保存し、 圧縮処理は別にする必要があると思います。
検索すればいろいろあると思いますが、検索結果の一例まで。 http://scripting.cocolog-nifty.com/blog/2007/11/vbazip_a144.html （Mook） 2014/01/09(木) 11:31
返事が遅くなりました。 Mookさん ＞ThisWorkbook.SaveCopyAs strZIP ＞は無茶な気がします。 私も無茶だと思っていますが、ご存知の通り2007以降の保存形式ならば、 例えば「test.xlsx」を「test.xlsx.zip」にリネームすることで、画像を取り出せることを利用して、 「ZIP形式で圧縮」が目的ではなく、「ZIPの拡張子にりネームして、エクスプローラで開く」が目的 になります。
なので ＞EXCEL は ZIP フォーマットで保存できませんので、いったん通常のファイル形式で保存し、 ＞圧縮処理は別にする必要があると思います。 これだと、ZIPファイルの中にエクセルファイルがあるだけなので、意味がないのです。 （たぶん）
あやさん 使用しているエクセルは2013ですよね？ マクロが保存されているブックの形式はxlsmではなくxlsになっていませんか？ xlsm形式に変換してもう一度試してみてください。 （稲葉） 2014/01/10(金) 09:49
>例えば「test.xlsx」を「test.xlsx.zip」にリネームすることで、画像を取り出せることを利用して、 言われてみると、そういう話があったような気がしますが、それは標準仕様ではなくて、 フォーマットが XML に変わったことの副作用的なものなので、通常の機能とは思わない 方が良い気がします。
ただ、上記であれば、xlsx(もしくはxlsm)形式で（SaveCopyAsで）保存して、名前を変える という処理にすれば良いのではないでしょうか。
最初から Save で名前とフォーマットを指定すればできるかもしれませんが、確認してい ないので「おそらくこうだろう」という話ですが。 （Mook） 2014/01/10(金) 13:06
稲葉さん、なんどもありがとうございます。
ややこしくて申し訳ないのですが 2010はクラウドシステムで動いております。
xlsmにすることはできたのですが 実行すると 「（指定フォルダ）は読み取り専用です。アクセスできません」となりました
あまりよくわかっていないのですがクラウドのせいかと思うのですが… 知識が無いのでどうもできずにいます-д-;
Mookさん、ありがとうございます。 おっしゃってることはなんとなくわかったつもりです >通常の機能とは思わない方が良い気がします。 ここはよく覚えておきます。 （あや） 2014/01/10(金) 13:23
＞〜〜それは標準仕様ではなくて、 ＞〜〜通常の機能とは思わない ＞方が良い気がします。 肝に銘じておきます。
＞ただ、上記であれば、xlsx(もしくはxlsm)形式で（SaveCopyAsで）保存して、名前を変える ＞という処理にすれば良いのではないでしょうか。 めんどくさかったのと、出来てしまったのでコードサボりました。 すみません。
あやさん すみませんが、今回は出来る出来ないだけで、あやさんが使う・使わないを選択して頂ければ ありがたいです。 なので、使用したことによるあらゆる弊害は、マイクロソフト社はございません、と付け加え させてください。
書き直しますので少々お時間ください。 またCドライブ直下はアクセスできますか？
（稲葉） 2014/01/10(金) 15:17
保存したい場所をstrPTに入れてください。（最後の\はなし） Sheet3はOption Explicit入れておくと、定義されてないって怒られたので変更しました。 .Pictures.Insertメソッドは、2010から仕様が変わっているようなので、 .Shapes.AddPictureメソッドに直しました。 あとはNameステートメントとKillステートメントで細かい処理しました。
全部差し替えです。
Option Explicit
Dim colItem As New Collection
Const strPT As String = "C:\エクセルの学校"
Const strFN As String = "test"
Const Target As String = "jpeg"
Public Sub サイズ変更2()
Dim W As Integer
Dim objSP As Shape
Dim StrFPath As String
Dim Fbuf As String
Dim strZIP As String
Dim strXLM As String
'==サイズ指定
On Error Resume Next
W = CInt(InputBox("変更したいサイズの横幅を入力してください", , 640))
If Err > 0 Then MsgBox ("数値で入力してください"): Exit Sub
On Error GoTo 0
'==変数設定
StrFPath = Sheets("Sheet3").Lblフォルダ指定.Caption
Fbuf = StrFPath & "\" & Dir(StrFPath & "\" & "*")
strZIP = strPT & strFN & ".zip"
strXLM = strPT & strFN & ".xlsm"
'==画像の挿入及びサイズ変更
Application.ScreenUpdating = False
With ActiveSheet
.Shapes.SelectAll
Selection.Delete
Do While Fbuf <> StrFPath & "\"
Set objSP = .Shapes.AddPicture(Fbuf, False, True, 0, 0, 0, 0)
With objSP
.ScaleHeight 1!, msoTrue
.ScaleWidth 1!, msoTrue
.LockAspectRatio = True '指定した図形のサイズを変更しても元の比率が保持される
If .Width < .Height Then
.Height = W
Else
.Width = W
End If
.Cut
End With
.PasteSpecial Format:="図 (JPEG)"
Fbuf = StrFPath & "\" & Dir()
Loop
End With
'==ファイルをxlsmで保存
ThisWorkbook.SaveCopyAs strXLM
'==.zipにリネーム
Name strXLM As strZIP
'==画像をzupから取り出す（Not標準機能）
Call 画像取得(strZIP, strPT)
'==作ったファイルを消す
Kill strZIP
Application.ScreenUpdating = True
MsgBox ("画像を" & strPT & "に保存しました。")
End Sub
Private Sub 画像取得(ByVal strGetPath As Variant, ByVal strOutPath As Variant)
Dim objFolder
Dim c As Object
With CreateObject("Shell.Application")
Set objFolder = .Namespace(strGetPath)
Call GETZIP(objFolder.Items())
Set objFolder = .Namespace(strOutPath)
For Each c In colItem
objFolder.CopyHere c
Next
End With
Set objFolder = Nothing
End Sub
Private Sub GETZIP(tmpF)
Dim tmpI As Object
For Each tmpI In tmpF
With tmpI
If tmpI.IsFolder Then
Call GETZIP(tmpI.GetFolder.Items())
Else
If tmpI.Name Like "*" & Target Then
colItem.Add tmpI
End If
End If
End With
Next
End Sub
（稲葉） 2014/01/10(金) 18:00
＞ ＞〜〜それは標準仕様ではなくて、 ＞ ＞〜〜通常の機能とは思わない ＞ ＞方が良い気がします。 ＞ 肝に銘じておきます。
えらい素直ですね。 テストして問題ないと確認したのなら、回り道しなければならない理屈か私には分からないです。 逆算すれば、標準仕様がファイル名はユーザーの指定に従うと云うことなんじゃないですか？ それは言い過ぎ？ しかし、少なくともZIPに関しては旨く行っても私は何の違和感もないです。 今のエクセルファイルはZIPファイルなんですから。
（半平太） 2014/01/10(金) 19:34
半平太さん 確かにテストして問題ないの確認しております。 .txtも.batや.htmlに書き換えられたのでいいのかなーってな具合でやっちゃってたので 先生方に違うんじゃない？って言われたらそうなのかーと思ってしまいます。 間違えや勘違いが多いので・・・ 2行増えただけですし、別にいいかな？とも・・・
それよりも、作り終えた後のテストで、「ファイルがあります」エラーを調べたら 「CopyHere メソッドから Zip ファイルを処理することはできません」 http://support.microsoft.com/kb/2679832/ja
こっちのほうが問題なんじゃないかと・・・ これも「できちゃったから」OK？
（稲葉） 2014/01/10(金) 21:03
うーん、私の知識が不足していた？ http://pc.nikkeibp.co.jp/article/NPC/20060629/242158/ 結構一般的な周知の事実だったでしょうか。 （Mook） 2014/01/10(金) 22:09
＞ こっちのほうが問題なんじゃないかと・・・ ＞ これも「できちゃったから」OK？
こっちはそうも行かなそうですね ＾＾
言われてみると、ZIPファイルからなんか取り出すのって、 危なっかしーからサポート対象外になってもしょうがないかも知れないです。
そうなると、Webページの発行ですかね？
（半平太） 2014/01/10(金) 23:01
稲葉さんの質問は
.Namespace(strGetPath)を.Namespace((strGetPath))にしてみたらどうなりますか？
あとstringでもconstなら大丈夫だった気がするので、
値を渡さずそのまま使えばいいような予感がします。
(特に試してないので的外れだったらスルーしてください)
（日捲り熊五郎） 2014/01/11(土) 00:34
htmlで試してみましたが、全部pngに。 2003使っていた時はjpgで保存出来ていた気がするのですが・・・。
日捲り熊五郎さん ありがとうございます。 試してみて動くようになりました。 Namespace側の引数の型が違っていたので、強制的に値を渡す必要があったってことですよね？ http://msdn.microsoft.com/ja-jp/library/chy4288y.aspx
（稲葉） 2014/01/14(火) 09:25
すみません ついていけてなくて^^;
htmlの保存のほうがよいのかな？ でもせっかく作っていただいたのでサイズ変更2試しておりました パスまでこちらの環境に合わせて 設定してくださりありがとうございます
動かしてみたところ 作業は終了した感じなのですが 画像サイズは小さくなっておりません
わからないなりに確認したこと
Const strPT As String = "C:\画像" にしました
'==ファイルをxlsmで保存 ThisWorkbook.SaveCopyAs strXLM
→C:\ に 画像test.xlsmが作られる ちなみに、エクセル2010クラウドの環境で開こうとすると 「Excelファイル'画像test.xlsm'を開くことができません。 ファイル形式またはファイル拡張子が正しくありません。 ファイルが破損しておらず、ファイル拡張子とファイル形式が一致していることを確認してください。」 というエラーメッセージが出ます
そのまま進めて
'==.zipにリネーム Name strXLM As strZIP
→C:\ に 画像test.zipが作られる ダブルクリックすると 「圧縮（Zip形式）フォルダは無効であるか、または壊れています」 というエラーメッセージが出ます
'==画像をzupから取り出す（Not標準機能） Call 画像取得(strZIP, strPT)
この中の Call GETZIP(objFolder.Items())で objFolder.Items()に何も入っていない状態で GETZIP(tmpF)に進んでいるのですが
なにか使い方が間違っていますでしょうか？
またなにかありましたら、アドバイスよろしくおねがいします。
話しに入れていませんが必死に読んでいますので^^; （あや） 2014/01/14(火) 11:32
再現できなーい！
ブックのバージョンがどうなっているのか気になるので、同じブックに↓を入れて、でてきた数値を
教えてください。
Sub BookF()
MsgBox (ThisWorkbook.FileFormat)
End Sub
（稲葉） 2014/01/14(火) 12:03
稲葉さんありがとうございます
-4143 になりました
すみません。実際 objFolder.Items() には、何が入ってくるものなのでしょうか？
（あや） 2014/01/14(火) 12:16
objFolder.Items()は後述します。
まず先ほど調べてもらった「-4143」は定数xlWorkbookNormalのことです。
【引用ここから】 FileFormat パラメータに xlWorkbookNormal を指定すると、Excel のバージョンに依存せず、常に Excel 97-2003 の互換ブックとして保存します。 【ここまで】
ということですので、 http://www.relief.jp/itnote/archives/013957.php こちらを参考に、xlsmに「変換」してから試してください。
objFolder.Items()は、Shell.Applicationのnamespaceメソッドでフォルダオブジェクトを作り、 itemsメソッドでファイルのオブジェクトを入れています。 ファイルが複数ある場合は、()とすることでオブジェクトのコレクション（でいいのかな）を 引数として渡しています。
なので、イミディエイトウィンドウで()に数値を入れてnameプロパティなどでどの番号にどの ファイルオブジェクトが当てはめられているか確認してみてください。
（稲葉） 2014/01/14(火) 12:54
少しずつ理解しようとしていたところだったんですが 依頼していた人から、必要なくなりましたとの言葉
完成するまで作りたかったのですが 時間的な問題でさわれなくなってしまいました。 また合間見て質問させてもらうことがありましたら よろしくおねがいしますm(__)m
せっかくお時間頂いたのに、すみません。 ありがとうございました （あや） 2014/01/22(水) 10:01
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.