[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『【VBA】全体を通したソースコードの見直し』（Seto）
先日よりディレクトリから画像ファイルを検出及び貼り付けをするスクリプトについて質問させて頂いた物です。
とりあえず目的の動作をこなせる形でコードが完成したので、その件につきましては完了となりました。
そのスレッドでもご説明した通り、VBAを学び始めて一週間も経っていない為、コードの書き方が非常に雑になっていると思われます。
画像を大量に扱うスクリプトの為、高速化等が見込まれるのであればそれを目的としたアップデートも行いたいですし、なにより単純にスマートなコードの書き方を学びたいと考えています。
下記に今回作成したコードを公開しますので、お気づきの点があれば指摘していただけるとありがたいです。
−−−−−−−−−−−−−code−−−−−−−−−−−−−
Option Explicit
'------------------------------------------------------------------------
'◆VBA
'
'◆動作概要
' 選択したディレクトリから一階層下までディレクトリの検出、
' 検出されたディレクトリの中から画像ファイルのみを判別、
' 画像ファイルに対してシートへの貼り付けを実行。
'
'◆仕様
' 画像ファイルは画像ファイル用ルートディレクトリから一階層下のみに保管する事
'------------------------------------------------------------------------
Dim Root_path As Variant, Sub_Dir As Variant, File_Name As Variant, pt As Double
Sub Select_Root_of_Image()
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
Root_path = .SelectedItems(1)
End With
ScanDir (Root_path)
End Sub
Sub ScanDir(Root_path As Variant)
Dim CO_SFSO, Root_Dir
Set CO_SFSO = CreateObject("Scripting.FileSystemObject")
Set Root_Dir = CO_SFSO.Getfolder(Root_path)
For Each Sub_Dir In Root_Dir.SubFolders
MakeSheet CStr(Sub_Dir)
ScanFile CStr(Sub_Dir)
Next Sub_Dir
End Sub
Sub MakeSheet(Sub_Dir As Variant)
Dim Sheet_Name As String
Worksheets.Add
Sheet_Name = Right(Sub_Dir, InStr(StrReverse(Sub_Dir), "\") - 1)
ActiveSheet.Name = Sheet_Name
End Sub
Sub ScanFile(Sub_Dir As Variant)
Dim CO_SFSO, File_Names, is_Image, POS
Set CO_SFSO = CreateObject("Scripting.FileSystemObject")
is_Image = True
For Each File_Name In CO_SFSO.Getfolder(Sub_Dir).Files
POS = InStrRev(File_Name, ".")
If POS > 0 Then
Select Case LCase(Mid(File_Name, POS + 1))
Case "jpeg"
Case "jpg"
Case "png"
Case Else
is_Image = False
End Select
Else
is_Image = False
End If
If is_Image = True Then
PasteFile CStr(File_Name)
End If
Next File_Name
End Sub
Sub PasteFile(File_Name As Variant)
Set File_Name = ActiveSheet.Shapes.AddPicture( _
filename:=File_Name, _
LinkToFile:=False, SaveWithDocument:=True, _
Left:=Selection.Left, Top:=Selection.Top, _
Width:=0, Height:=0)
File_Name.ScaleHeight 1!, msoTrue
File_Name.ScaleWidth 1!, msoTrue
MoveDown File_Name.Height
End Sub
Sub MoveDown(pt As Double)
Dim moved As Double
moved = 0
Do While moved <= pt
moved = moved + ActiveCell.Height
ActiveCell.offset(1, 0).Activate
Loop
ActiveCell.offset(2, 0).Activate
End Sub
＜ 使用 Excel：unknown、使用 OS：Windows7 ＞
Select_Root_of_Image()
・ダイアログで指定せずにキャンセルした場合はどうする？
ScanDir()
・2度目の実行時、既に同名のシートが存在するのでエラーになるが、どうする？
（元の質問内容には含まれなかったので、私も手抜きしましたが、元シートへの追記を考えても良いのでは？）
ScanFile()
・フォルダ数分呼ばれる訳ですが、その度にCreateObjectしているので、どんどんメモリを食っていきますよ？
（使い終わったリソースは、開放すべき。プロシジャ終了時にVBAが自動開放してくれますが、この場合は明示した方が良い）
・処理無しCase文の縦の列挙は格好悪いです。また、目的の拡張子ならば処理、というコーディングの方が自然では？
・過剰なフラグ化は、コードが読みづらくなります。変数 is_Image を使わずに書いてみては？
MoveDown()
・大した処理ではないので、PasteFile() に含めてみては？ VBAはインタプリンタ言語なので、完全な最適化より、プロシジャ呼び出しのオーバーヘッドを減らす方が良いでしょう。
・ActiveCellやoffsetによる相対指定は、後でコードを読んだときにロジックが判りにくいと感じます。
（???） 2016/11/14(月) 13:31
・そもそもディレクトリを選択しなかった場合は、下位メソッドで指定エラーが出る為、それ以上コードが走らないはずと考えています。
・同一名によるエラーは、Root_DirのサブディレクトリをSub_Dirに一つずつ格納しながら下位メソッドを呼び出すfor文になっている為、サブディレクトリそのものが同名で存在しない限りエラーは起こらないと考えています。(少なくとも私の環境では動作確認済みです)
・CreateObjectの根本的な動作について理解していませんでした、これは怖いですね、、、スグに修正します。
・動作フローとCase文の記載方法について、仰るとおりだと思います、自分でも何故こんなややこしい書き方にしたのか分かりません。
・MoveDown()のオーバーヘッド削減の考え方については、そもそもインタプリタ言語と言う物を理解していないので、根本的に学習し直してから修正を検討してみたいと思います。
・ActiveCellとOffsetについて、VBAを習う上でOffsetとRangeとColumnにActiveCellを絡めて使えるようになればセル移動に困らないと考えこれ関係ばかり記事を読んだので、むしろこれ以外の方法が分からない状態です。このあたりはもう少し基礎から調べてみます。
多くの意見が頂けて非常に助かります。
（Seto） 2016/11/14(月) 14:12
Select_Root_of_Image()
・試せば一瞬で判る事でしたが、ご理解頂けなかったようなので、対策だけ。
If .Show <> True Then Exit Sub
欄外
・先頭で4つの変数を宣言してますが、この位置に宣言すると、モジュール内共通変数になります。 つまり、引数指定せずとも、他のプロシジャ全てで値の参照やセットができる、ということ。 それなのに、作成したプロシジャには引数宣言があります。 これはミスの元なので、止めましょう。 カプセル化の考え方を壊す使い方です。
（呼び元のプロシジャ内で宣言し、引数指定で受け渡すべき。スコープは最小限にすること）
MakeSheet()
・StrReverse命令は、存在を忘れてしまっても良いくらい、出番のないものです。 文字列を全部ひっくり返すという、どう考えても遅い命令です。 他のプロシジャではInStrRevを使っているのだから、統一しましょう。
Sheet_Name = Right(Sub_Dir, InStr(StrReverse(Sub_Dir), "\") - 1)
↓
Sheet_Name = Mid(Sub_Dir, InStrRev(Sub_Dir, "\") + 1)
MoveDown()
・Offset や Activate を避ける方法として、Cells(行、列） でセル指定する方法があります。 これだと絶対位置指定なので、判りやすいでしょう。 そもそも、ループして比較せずとも、画像サイズとセルサイズを比べれば、次はどのセルかが判明するのでは？
（セル高さが1行毎に違う、とかならば意味がありますが、遅そう）
そもそも、AddPictureに指定する値は座標なのだから、セル位置は使わない方が良いのでは？
（???） 2016/11/14(月) 15:28
グローバル変数宣言の乱用、と言う奴ですね。
スコープは最小限にと言う言葉は今後コードを書く際に肝に銘じて作業します。
InStrRevのコード、非常に助かりました。
ここは私のほうでも統一をさせようとしていたのですが、エラーをはく為保留としていました。
正解を見てしまったせいか自分がどう間違っていたかが思い出せなくなってしまったのですが、各コード別に関連付けて学習し理解出来るよう努力します。
確かに、MoveDownは結構無駄と言うか適性の低い処理になっていますね。
仰られている事をスグにコードにたたき出す知識が無いので、方法を模索して修正に望みます。
淡々とレスポンスを返していますが目から鱗ばかりで本当に助かっています。
（Seto） 2016/11/14(月) 16:26
Option Explicit
'--------------------------------------------------------------------------------------
'◆VBA
'
'◆動作概要
' 選択したディレクトリから一階層下までディレクトリの検出、
' 検出されたディレクトリの中から画像ファイルのみを判別、
' 画像ファイルに対してシートへの貼り付けを実行。
'
'◆仕様
' 画像ファイルは画像ファイル用ルートディレクトリから一階層下のみに保管する事
'--------------------------------------------------------------------------------------
Sub Select_Root_of_Image()
'各画像ファイルが格納されたディレクトリを管理しているルートディレクトリを選択
Dim Root_path As Variant
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show <> True Then Exit Sub
'ファイル参照されなかった場合スクリプトを終了
Root_path = .SelectedItems(1)
End With
'Windowsのダイアログを使用して選択、選択後は値を変数へ代入
ScanDir (Root_path)
'ルートディレクトリのフルパスを引数にして下位プロシージャの呼び出し
End Sub
Sub ScanDir(Root_path As Variant)
'ルートディレクトリ直下にあるサブディレクトリの検出
Dim CO_SFSO, Root_Dir, Sub_Dir
Set CO_SFSO = CreateObject("Scripting.FileSystemObject")
Set Root_Dir = CO_SFSO.Getfolder(Root_path)
'CreateObjectを使用しルートディレクトリ直下のサブディレクトリをオブジェクト化して変数へ代入
For Each Sub_Dir In Root_Dir.SubFolders
Set CO_SFSO = Nothing
'*****メモリ開放(位置を確認)
NewSheetAndScanFiles (Sub_Dir)
Next Sub_Dir
'For文内でプロシージャ内の上位メソッドで検出したサブディレクトリを一つずつ判定
'その判定毎にシート作成と画像ファイル検出の下位プロシージャを呼び出し
End Sub
Sub NewSheetAndScanFiles(Sub_Dir)
'引数サブディレクトリ内から条件分岐等で画像ファイルのみを判定させる
Dim CO_SFSO, File_Name, File_Names, isImage, POS, Sheet_Name As String
Worksheets.Add
Sheet_Name = Mid(Sub_Dir, InStrRev(Sub_Dir, "\") + 1)
ActiveSheet.Name = Sheet_Name
'シート作成後サブディレクトリのフルパスから、末尾の名前のみを抽出、それをディレクトリ名へ適用
Set CO_SFSO = CreateObject("Scripting.FileSystemObject")
'CreateObjectでサブディレクトリ内の画像ファイルをオブジェクト化
For Each File_Name In CO_SFSO.Getfolder(Sub_Dir).Files
'同プロシージャ内でオブジェクト化したファイル群をFor文で一つずつ処理
Set CO_SFSO = Nothing
'*****メモリ開放(位置を確認)
POS = InStrRev(File_Name, ".")
'拡張子に伴うピリオドの位置を変数に代入した値
If POS > 0 Then
Select Case LCase(Mid(File_Name, POS + 1))
Case "jpeg", "jpg", "png"
PasteFile CStr(File_Name)
Case Else
End Select
Else
End If
'上記変数とそれ以降の文字列から画像ファイルか否かの判定
'画像ファイルと判定された場合のみペースト用のプロシージャを呼び出し
Next File_Name
End Sub
Sub PasteFile(File_Name As Variant)
'引数で受け取ったファイルパスを元にアクティブセルへ画像をペースト
Dim moved As Double
moved = 0
'このプロシージャは上位プロシージャ内のFor文内で処理される物なので
'画像間隔を統一する為にプロシージャ呼び出し毎に変数を初期化
Set File_Name = ActiveSheet.Shapes.AddPicture( _
filename:=File_Name, _
LinkToFile:=False, SaveWithDocument:=True, _
Left:=Selection.Left, Top:=Selection.Top, _
Width:=0, Height:=0)
'引数の内容をそのままアクティブセルへ貼り付け
'プロパティの参照等は行っていないので画像サイズが不明なので
'0*0の仮想的な最小サイズで一時的に対応
File_Name.ScaleHeight 1!, msoTrue
File_Name.ScaleWidth 1!, msoTrue
'最小サイズで一時対応だった画像ファイルを適切なサイズへ修正
'元ファイルからサイズ情報をそのまま参照し、等倍でサイズ決定
Do While moved <= File_Name.Height
moved = moved + ActiveCell.Height
ActiveCell.offset(1, 0).Activate
Loop
'引数のHeight以上になるまでセルを一つずつ動かしその位置を記憶
ActiveCell.offset(2, 0).Activate
'Heightに依存しない固定された間隔を設ける為の固定値移動
'同プロシージャ内で判明した画像ファイルの高さを引数に下位プロシージャ呼び出し
End Sub
（Seto） 2016/11/14(月) 17:09
序盤のみ整形した例です。
'各画像ファイルが格納されたディレクトリを管理しているルートディレクトリを選択
Sub Select_Root_of_Image()
Dim Root_path As String
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show <> True Then Exit Sub 'ファイル参照されなかった場合スクリプトを終了
Root_path = .SelectedItems(1) 'Windowsのダイアログを使用して選択、選択後は値を変数へ代入
End With
Call ScanDir(Root_path) 'ルートディレクトリのフルパスを引数にして下位プロシージャの呼び出し
End Sub
'ルートディレクトリ直下にあるサブディレクトリの検出
Sub ScanDir(Root_path As String)
Dim Root_Dir As Object
Dim Sub_Dir As Object
Set Root_Dir = CreateObject("Scripting.FileSystemObject").Getfolder(Root_path)
For Each Sub_Dir In Root_Dir.SubFolders
Call NewSheetAndScanFiles(Sub_Dir) 'シート作成と画像ファイル検出の下位プロシージャを呼び出し
Next Sub_Dir
End Sub
'引数サブディレクトリ内から条件分岐等で画像ファイルのみを判定させる
Sub NewSheetAndScanFiles(Sub_Dir As Object)
Debug.Print Sub_Dir.Path
End Sub
（???） 2016/11/14(月) 17:30
明日、ご指摘の内容に沿って学習し、また午後にでも修正した結果を公開できればと考えています。
（Seto） 2016/11/14(月) 17:51
セル移動に関しては無駄なDoWhileこそ無くしましたが、どうも個人的にActiveCellとOffsetの方が理解しやすいので、若干指摘からそれた方向性になっています。
オブジェクト参照の解放について場所があっているかどうかが少し不安です。
Option Explicit
'--------------------------------------------------------------------------------------
'◆VBA
'
'◆動作概要
' ルートディレクトリの選択、直下サブディレクトリ検出、サブディレクトリ毎のシート作成、
' サブディレクトリ内の画像検出、シートへのペーストと移動
'
'◆仕様
' 画像ファイルは画像ファイル用ルートディレクトリから一階層下のみに保管する事
'--------------------------------------------------------------------------------------
Sub Select_Root_of_Image() 'ルートディレクトリの選択
Dim Root_path As Variant
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show <> True Then Exit Sub '選択されないと終了
Root_path = .SelectedItems(1)
End With
ScanDir (Root_path) '選択したフルパスを引数に設定
End Sub
Sub ScanDir(Root_path As Variant) '引数パス直下のサブフォルダ検出
Dim dirFSO, Root_Dir As Object, Sub_Dir As Object
Set dirFSO = CreateObject("Scripting.FileSystemObject")
Set Root_Dir = dirFSO.Getfolder(Root_path)
For Each Sub_Dir In Root_Dir.SubFolders 'オブジェクト参照で検出しFor文で回す
Call NewSheetAndScanFiles(Sub_Dir) '各サブフォルダのフルパスを引数に設定
Next Sub_Dir
Set dirFSO = Nothing 'プロシージャ終了前に明示的に解放
End Sub
Sub NewSheetAndScanFiles(Sub_Dir As Object) 'シートの挿入と画像ファイルの検出
Dim imgFSO, File_Name, File_Names, POS, Sheet_Name As String
Set imgFSO = CreateObject("Scripting.FileSystemObject")
Worksheets.Add
Sheet_Name = Mid(Sub_Dir, InStrRev(Sub_Dir, "\") + 1)
ActiveSheet.Name = Sheet_Name '引数パスからフォルダ名を抽出しシート名に反映
ActiveCell.offset(3, 0).Activate '見出しやタイトル用余白
For Each File_Name In imgFSO.Getfolder(Sub_Dir).Files 'サブフォルダ検出時と手法は同じ
POS = InStrRev(File_Name, ".") '拡張子に付随するピリオドを変数化
If POS > 0 Then 'ピリオド以降の文字列を利用し拡張子の判別
Select Case LCase(Mid(File_Name, POS + 1))
Case "jpeg", "jpg", "png"
PasteFile CStr(File_Name) '画像ファイルと認識したら下位プロシージャへ
Case Else
End Select
Else
End If
Next File_Name
Set imgFSO = Nothing 'こちらもプロシージャ終了時に明示的に解放
End Sub
Sub PasteFile(File_Name As Variant) '画像貼り付けとそれに伴うセル移動
Dim imgHeight As Double
Set File_Name = ActiveSheet.Shapes.AddPicture( _
filename:=File_Name, _
LinkToFile:=False, SaveWithDocument:=True, _
Left:=Selection.Left, Top:=Selection.Top, _
Width:=0, Height:=0) '元ファイルとのリンクは無し
File_Name.ScaleHeight 1!, msoTrue
File_Name.ScaleWidth 1!, msoTrue
imgHeight = File_Name.Height / ActiveCell.Height '画像の高さをセルを単位に算出
imgHeight = Application.RoundUp(imgHeight + 2, 0)
ActiveCell.offset(imgHeight, 0).Activate '統一された余白確保の為固定値を足して整数分移動
End Sub
（Seto） 2016/11/15(火) 12:33
再度直したコードをアップする必要はありませんし、そのままにしておいて、数年後にご自分でコードを読み直してみるのも良いですよ。とりあえず、指摘を列挙しておきますね。
Select_Root_of_Image()
・Root_pathは.SelectedItems(1) と、選択されたフォルダの先頭の文字列だけ格納しているので、Variant型である必要はありません。だから String型に変更しておいたのですが、理解して頂けなかったようです。変数のスコープはなるべく狭く、というのと同様に、型宣言もなるべく狭くした方が、コードの可読性が上がるのですよ。（Variant型だと、そこは配列が入るのか、日付型の可能性はあるのか、等、全体を読まないと値の範囲が判りませんが、String型ならば文字列なんだな、と一目で判ります）
ScanDir()
・引数は親フォルダ名1つしかあり得ないので、Variant型は不適切です。何でもかんでも可変定義するのは、手抜き。
・変数宣言は1行にまとめず、バラしましょう。例えば、
Dim dirFSO, Root_Dir As Object, Sub_Dir As Object
こう書いていますが、dirFSOは指定がないので、Variant型になります。つまり、手抜き。読みにくい。予期せぬ型変換による不具合を潜在してしまう可能性。必要な場合以外は、Variant型は使わない癖を付けましょう。 なお、CreateObjectとオブジェクト生成しているのだから、dirFSOはObject型にすべきですね。
・Call NewSheetAndScanFiles(Sub_Dir) と、Sub_Dirオブジェクトを引数渡ししていますが、受け渡すサイズは小さい方が良い事を考えると、フォルダ名さえ渡せば良いので、Sub_Dir.Path を渡すべき。 整形例で Debug.Print を残したのは、プロパティを伝えたかったためですが、伝わらなかったようですね。 プロパティを省略するとPathが採用されるので、たまたま正しく動くだけです。これも手抜き。
Sub_Dirオブジェクトを使っている箇所にブレークポイントを設定し実行。止まったところでSub_Dirを「デバッグ」−「ウォッチ式の追加」としてみてください。Sub_Dirオブジェクトの持つプロパティやメソッドを確認することで、オブジェクト型の大きさを理解できる事でしょう。（ウォッチウィンドウのSub_Dirを右クリックし、削除することで、元に戻ります）
NewSheetAndScanFiles()
・これも同様。引数がオブジェクトなのか文字列なのか、はっきりさせること。現状は、Object型と明記していながら、文字列として使っているので、気持ち悪いコーディングになってます。たまたま正しく動いているだけです。
・他のプロシジャもですが、File_Names という変数は未使用です。必要な変数は必ず宣言し、不要な変数は宣言しない事が、可読性を上げます。
PasteFile()
・今回はアクティブセルのままとの事なのでこのままですが、もし座標またはセル位置を明示するならば、このプロシジャに引数追加し、Y座標またはセルの行番号を指定すると良いでしょう。 アクティブセルを利用するのは、カプセル化の考えから外れているので。
全体
・行後ろにコメントを書くときは、TABを利用して、縦が同じ位置になるよう統一すると、ロジックが追いやすくなります。
（Sub 宣言のコメントは、ロジック中のと揃える必要は無し）
（???） 2016/11/15(火) 14:30
＞Sub Select_Root_of_Image()
確かにフォルダの選択から始まるのでしょうが、
どうせなら、フォルダーの選択を関数にした方がいいのかなと思いました。
メインの作業の流れは、
0）プログラム始め
1） フォルダの選択
2） 選択したフォルダーの各サブフォルダーに対して繰り返し
3） 各サブフォルダーの中の各ファイルに対して繰り返し
4） もし、各ファイルが、画像ファイルならシートに挿入
5） 次のファイルへ
6） 次のフォルダーへ
7）プログラム終わり
だと思うので、それを主体に書いて、
各作業をサブルーチンにしたらいいかなと思いました。
＞CreateObject("Scripting.FileSystemObject")
が、別べつのプロシージャに出てくるので、
当初に一回開いて、
最後に閉じちゃえばいいかなと思いました。
また、FSOを使ってるならFSOで拡張子が簡単に得られるようなので、
そっちを使ったらいいかなぁと思いました。
＞imgHeight = File_Name.Height / ActiveCell.Height
画像の大きさで、次の貼付位置を計算してるのかなぁ？
セルを相対位置で指定していけばいいかなぁと思いました。。。
Option Explicit
'※参照設定でMicrosoft Scripting Runtimeにチェックを入れること
Sub test()
Dim sRoot_path As String
Dim FSO As FileSystemObject
Dim oFolder As Folder
Dim oFile As File
Dim rngTarget As Range
Dim wbResult As Workbook
If GetSelectFolder(sRoot_path) = False Then Exit Sub
'Application.ScreenUpdating = False
Set FSO = New FileSystemObject
For Each oFolder In FSO.GetFolder(sRoot_path).SubFolders
Set rngTarget = GetNewSheet(wbResult, oFolder.Name)
For Each oFile In oFolder.Files
Select Case FSO.GetExtensionName(oFile.Path)
Case "jpeg", "jpg", "png", "JPEG", "JPG", "PNG"
SetInsertPicture oFile.Path, rngTarget
End Select
Next
Application.StatusBar = oFolder.Name & "フォルダー処理中"
Next
Application.StatusBar = False
End Sub
Private Function GetSelectFolder(ByRef sFolderName As String) As Boolean
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show Then
sFolderName = .SelectedItems(1)
GetSelectFolder = True
End If
End With
End Function
Private Function GetNewSheet(ByRef wb As Workbook, _
ByVal sName As String) As Range
If wb Is Nothing Then
ThisWorkbook.Sheets(1).Copy
Set wb = Workbooks(Workbooks.Count)
Else
ThisWorkbook.Sheets(1).Copy After:=wb.Sheets(wb.Sheets.Count)
End If
With wb.Sheets(wb.Sheets.Count)
.Name = sName
Set GetNewSheet = .Range("A1")
End With
End Function
Private Sub SetInsertPicture(ByVal sFullPath As String, _
ByRef rngTarget As Range)
Dim pic As Shape
With rngTarget
Set pic = rngTarget.Worksheet.Shapes.AddPicture( _
Filename:=sFullPath, _
LinkToFile:=False, _
SaveWithDocument:=True, _
Left:=.Left, Top:=.Top, Width:=0, Height:=0)
pic.ScaleHeight 1, msoTrue
pic.ScaleWidth 1, msoTrue
pic.LockAspectRatio = msoTrue
pic.Height = .Height - 10
pic.Top = .Top + 5
pic.Left = .Left + (.Width - pic.Width) / 2
End With
Set rngTarget = rngTarget.Offset(1)
End Sub
※横着してコメントは入れてないです＾＾；
※写真貼付用のテンプレートは自ブックにあり、それをコピーして
新規ブックに画像を挿入する前提で書いてます。
※こちらも、面白そうなテーマなので勉強して書いてみただけなので、
「こんな書き方も出来るんだ。」という、参考程度と考えておいてください。
これが模範となるようなベストなコードではないと思いますので、
その辺はご了承願います。
※動作確認もあんまり詳しくはしてません。バグがあるかも知れません。
※高速化は、画面の更新を止めたら、少しは速くなると思います。
（まっつわん） 2016/11/15(火) 16:02
PasteFile() で画像サイズを見ているのは、画像は縮小せずそのまま貼って、2行空けた位置に次の画像、としているためです。
画像高さから、使った行数を計算している訳ですね。 行数を切り上げているのはこのため。 画像サイズがバラバラだと、行位置がバラバラになるので、アクティブ位置に貼る（そのために、貼り終わったらアクティブ位置を移動しておく）というロジックです。
Excelに画像を貼る場合、元サイズで貼ると大きすぎたり、貼る位置がバラバラになるので、固定サイズに縮小・拡大して、等間隔にするのが一般的かと思いますが、原寸を重視する考えも理解できるので、そこはそのままでも良い、と思いました。
（まっつわんさん案は、1セルの内側に画像を貼る、という方法なので、セルを大きくしておく必要があります）
まっつわんさんのコードの弱点は、拡張子の大文字小文字への対処ですかね。".jPg"とかだと反応しない…。Setoさんは、そこはLCaseで対応済みですね。
（???） 2016/11/15(火) 16:32
（Seto） 2016/11/15(火) 17:08
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.