Created
October 11, 2014 09:10
-
-
Save shirashin/f1e4c245d564e56819b6 to your computer and use it in GitHub Desktop.
画像を列挙したエクセルシートを作るマクロみたいな
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| ' ディレクトリ内のファイルを列挙 | |
| Sub CreateImgAlbum() | |
| y = 3 | |
| ' A1セルからディレクトリパス取得 | |
| root_dir = ActiveSheet.Cells(1, 1).Value | |
| y = SearchDir(root_dir, y, root_dir) | |
| Rows(5).EntireColumn.AutoFit | |
| Cells(y, 1).ColumnWidth = 5 | |
| MsgBox "OK!!" | |
| End Sub | |
| ' ディレクトリを探索 | |
| Private Function SearchDir(dir, y, root_dir) | |
| Set fso = CreateObject("Scripting.FileSystemObject") | |
| Set sub_dirs = fso.GetFolder(dir).SubFolders | |
| y = importImagesFromOneSubDir(fso.GetFolder(dir), y, root_dir) | |
| For Each sub_dir In sub_dirs | |
| y = importImagesFromOneSubDir(sub_dir, y, root_dir) | |
| For Each subsub_dirs In sub_dir.SubFolders | |
| y = SearchDir(sub_dir, y, root_dir) | |
| Next | |
| Next | |
| SearchDir = y | |
| End Function | |
| ' 画像を読み込み | |
| Private Function importImagesFromOneSubDir(sub_dir, y, root_dir) | |
| file_name = dir(sub_dir & "\*.*") | |
| Do While file_name <> "" | |
| If isImageFile(file_name) Then | |
| importImageFile file_name, y, root_dir, sub_dir | |
| y = y + 1 | |
| End If | |
| file_name = dir() | |
| Loop | |
| importImagesFromOneSubDir = y | |
| End Function | |
| ' 画像か判別 | |
| Private Function isImageFile(file_name) | |
| pos_period = InStrRev(file_name, ".") | |
| If pos_period > 0 Then | |
| file_ext = LCase(Mid(file_name, pos_period + 1)) | |
| If _ | |
| file_ext = "jpg" Or _ | |
| file_ext = "jpeg" Or _ | |
| file_ext = "bmp" Or _ | |
| file_ext = "gif" Or _ | |
| file_ext = "png" _ | |
| Then | |
| ret = True | |
| Else | |
| ret = False | |
| End If | |
| Else | |
| ret = False | |
| End If | |
| isImageFile = ret | |
| End Function | |
| Private Sub importImageFile(file_name, y, root_dir, sub_dir) | |
| file_path = sub_dir & "\" & file_name | |
| Cells(y, 1).ColumnWidth = 10 | |
| ' 2列目はディレクトリパス | |
| Cells(y, 2).Value = Replace(sub_dir.Path, root_dir, "") | |
| Cells(y, 2).ColumnWidth = 10 | |
| ' 3列目はファイル名 | |
| Cells(y, 3).Value = file_name | |
| Cells(y, 3).ColumnWidth = 10 | |
| Cells(y, 3).Value = file_name | |
| Cells(y, 3).ColumnWidth = 10 | |
| ' 5列目は画像 | |
| Cells(y, 5).RowHeight = 150 | |
| Cells(y, 5).ColumnWidth = 70 | |
| Set myRange = Cells(y, 5) | |
| Application.ScreenUpdating = False | |
| Cells(y, 5).Select | |
| Set myShape = ActiveSheet.Shapes.AddPicture( _ | |
| Filename:=file_path, _ | |
| LinkToFile:=False, _ | |
| SaveWithDocument:=True, _ | |
| Left:=Selection.Left, _ | |
| Top:=Selection.Top, _ | |
| Width:=1, _ | |
| Height:=1) | |
| With myShape | |
| .ScaleHeight 1, msoTrue | |
| .ScaleWidth 1, msoTrue | |
| .LockAspectRatio = msoTrue | |
| Cells(y, 4).Value = .Width * (96 / 72) & "x" & .Height * (96 / 72) | |
| Cells(y, 4).ColumnWidth = 10 | |
| ' 画像サイズ調整 | |
| If .Width >= myRange.Width Or .Height >= myRange.Height Then | |
| rX = myRange.Width / .Width | |
| rY = myRange.Height / .Height | |
| If rX > rY Then | |
| .Height = .Height * rY | |
| Else | |
| .Width = .Width * rX | |
| End If | |
| End If | |
| .Left = .Left + (myRange.Width - .Width) / 2 | |
| .Top = .Top + (myRange.Height - .Height) / 2 | |
| End With | |
| Application.ScreenUpdating = True | |
| Cancel = True | |
| End Sub | |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment