image_insert_vba (vba로 만든 이미지 자동 삽입기)
' each module has a intuitive and understnding name so I have not comment on each module
' 각 모듈이 직관적인 이름으로 되어 있어서 이해가 쉬울거에요
' 변수 선언
Option Explicit
Dim sFolder As String 'sFolder --> the folder of images
Dim file_name As String
Dim pic_name As String
Dim img As Picture
Dim X As Object 'X is a FileObject
Dim XNC As Object
Dim number_of_files As Integer
Const loc_data As Integer = 20 ' data loc is cells(1, 20)
Const no_of_column As Integer = 6
Const loc_data_copy As Integer = 23 ' data loc is cells (1, 20)
Dim file_arr As Variant
Dim file_name_in_cells_arr As Variant
' 이미지 삽입 프로세스
' 각 모듈을 불러오는 역할
Public Sub image_insert_process()
Application.ScreenUpdating = False
Call folder_Picking ' 폴더 선택
Call count_files_number ' 파일수 체크
Call list_files ' 파일 리스트 업
Call sortDataWithoutHeader ' 파일 소트
Call store_files_into_array ' 파일을 어레이에 넣기
Call putting_file_Names ' 파일명 셀에 넣기
Call row_col_adj '셀크기 조정
Call putting_images ' 이미지 넣기
Call clear_loc_data ' 기타 불필요 지우기
Call delete_extension ' 확장명 지우기
Call clear_boarder_colors ' 기타 불필요 서식 지우기
Call cells_Centered ' 중간으로 맞추기
Application.ScreenUpdating = True
Sheet1.Cells(1, 1).Select
End Sub
Private Sub row_col_adj()
Dim intRow As Integer
intRow = 1
Dim intCol As Integer
intCol = 1
Dim int_odd As Integer
int_odd = 1
Dim int_even As Integer
int_even = 2
Do While intRow < ((number_of_files / no_of_column) + 1)
For intCol = 1 To no_of_column
Sheet1.Cells(int_odd, intCol).Select
'Selection.Interior.ColorIndex = 20
Selection.RowHeight = 16.5
Selection.ColumnWidth = 15
Sheet1.Cells(int_even, intCol).Select
'Selection.Interior.ColorIndex = 15
Selection.RowHeight = 125
Next
int_odd = int_odd + 2
int_even = int_even + 2
intRow = intRow + 1
Loop
Sheet1.Range("A1").CurrentRegion.Select
Selection.Borders.Color = 20
End Sub
Private Sub folder_Picking()
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = -1 Then ' if OK is pressed
sFolder = .SelectedItems(1)
End If
End With
If sFolder <> "" Then
MsgBox "파일을 가져올 폴더 위치 확인 됨!" & vbCrLf & "a Path Identified "
Else
MsgBox "파일을 가져올 위치를 지정하세요!" & vbCrLf & "a Path, Please!!!"
Exit Sub
End If
End Sub
Private Sub count_files_number()
Set X = CreateObject("Scripting.filesystemobject")
Set XNC = X.GetFolder(sFolder) ' XNC is a file object
MsgBox "이미지 파일은 " & XNC.Files.count & "개입니다"
number_of_files = XNC.Files.count
End Sub
Private Sub list_files()
Dim get_file As Variant
Dim intRow As Integer
intRow = 1
For Each get_file In XNC.Files
Sheet1.Cells(intRow, loc_data).Value = get_file.name
intRow = intRow + 1
Next
End Sub
Private Sub sortDataWithoutHeader()
Sheet1.Range("T1", Range("T1").End(xlDown)).Sort Key1:=Range("T1"), Order1:=xlAscending, Header:=xlNo
End Sub
Private Sub store_files_into_array()
ReDim file_arr(1 To number_of_files)
Dim num_1 As Integer
For num_1 = 1 To number_of_files
file_arr(num_1) = Sheet1.Cells(num_1, loc_data).Value
Next
End Sub
Private Sub putting_file_Names()
Dim rn As Integer ' row of name
Dim cn As Integer ' column of name
Dim z As Variant ' z is each File
Dim f_a As Variant
rn = 1
cn = 1
For Each f_a In file_arr ' go through folder
' puting the file-names into cells
'Sheet1.Cells(rn, cn).Value = z.name 'Sheet1 is a code name not just a sheet-name
Sheet1.Cells(rn, cn).Value = f_a
cn = cn + 1
If cn >= 7 Then ' on 6th column, go down to the next row.
cn = 1
rn = rn + 2
End If
Next
End Sub
Private Sub putting_images()
Dim r As Integer
Dim c As Integer
Dim i As Integer
r = 1 ' row
c = 1 ' column
For i = 1 To XNC.Files.count ' as many as the rows of files
Do While c <= no_of_column ' as many as the columns of files
file_name = Sheet1.Cells(r, c).Value 'Sheet1 is a code name of the sheet not a name of a sheet
If file_name = "" Then
Exit Do ' if data is the last one then exit
End If
pic_name = sFolder & "\" & file_name
Cells(r + 1, c).Select ' where will be inserted
Set img = ActiveSheet.Pictures.Insert(pic_name)
With img
img.Top = .Top + 2
img.Left = .Left + 2
img.ShapeRange.LockAspectRatio = msoFalse
img.Placement = xlMoveAndSize
img.ShapeRange.Width = 80#
img.ShapeRange.Height = 110#
End With
c = c + 1 ' move to the right column
Loop
r = r + 2 ' go down to the next row
c = 1
Next
End Sub
Private Sub cells_Centered()
Cells.Select ' cells centered!!
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
End Sub
Private Sub clear_boarder_colors()
Sheet1.Cells.ClearFormats
End Sub
Private Sub clear_loc_data()
'Sheet1 is a code name of the sheet not a name of a sheet
Sheet1.Cells(1, loc_data).CurrentRegion.Delete
End Sub
Private Sub delete_extension()
Sheet1.Cells(1, 1).Select
Dim rn As Integer ' row of name
Dim cn As Integer ' column of name
Dim z As Variant ' z is each File
Dim file_name As Variant
Dim file_part() As String
rn = 1
cn = 1
For Each file_name In file_arr ' go through folder
file_name = Sheet1.Cells(rn, cn).Value
file_part = Split(file_name, ".")
Sheet1.Cells(rn, cn).Value = file_part(0)
cn = cn + 1
If cn >= 7 Then ' on 6th column, go down to the next row.
cn = 1
rn = rn + 2
End If
Next
End Sub
Public Sub image_delete_process()
Call DeleteAllPics
Call cells_row_back
End Sub
Private Sub DeleteAllPics()
Dim Pic As Object
For Each Pic In ActiveSheet.Pictures
Pic.Delete
Next Pic
Dim ws As Worksheet
Set ws = Sheet1 'Sheet1 is a code name of the sheet not a name of a sheet
ws.Cells.Clear
ws.Cells.ClearFormats
End Sub
Private Sub cells_row_back()
Sheet1.Cells.RowHeight = 16.5
Sheet1.Cells.ColumnWidth = 8.38
End Sub
댓글
댓글 쓰기