사진 자동입력하는 매크로 - manual/auto

Sub Get_Picture_auto()

    On Error GoTo File_error

Dim c_path, p_name, r_name, border

c_path = Application.ThisWorkbook.path '현재 문서의 디렉토리

border = 3

Input_p_heingt:         '사진 높이 입력

    h_zoom = 1

   'h_zoom = Application.InputBox(PROMPT:="사진 높이를 입력하세요(사진이 차지하는 행의 수)", Type:=2)

    'If h_zoom = False Then Exit Sub

    'If IsNumeric(h_zoom) = False Then GoTo Num_error

Repeat:

    prev_addr = ActiveCell.Address             '현재셀주소

    r_name = Selection.Text                    '현재셀을 사진화일 이름으로 사용

        If r_name = "" Then GoTo noname_error

    p_name = r_name + ".jpg"                   '사진화일명 생성

    p_height = Selection.Height                '현재셀의 높이(사진 높이의 기준이 됨)

    p_width_move = Selection.Offset(0, 0).Width    '현재열의 너비(사진의 폭이됨)

    p_width = Selection.Offset(0, 1).Width    '다음열의 너비(사진의 폭이됨)

    

    

    'Application.Dialogs(xlDialogOpen).Show

    'ins = Application.Dialogs(xlDialogInsertPicture).Show

    

   ActiveSheet.Pictures.Insert(c_path + "\" + p_name).Select

    'If ins Then

    With Selection

                  .ShapeRange.LockAspectRatio = msoFalse

                  .ShapeRange.Height = p_height * h_zoom - border * 2 '셀 높이 * 배율

                  .ShapeRange.Width = p_width - border * 2 '셀 너비 단위로 입력

                  .ShapeRange.IncrementLeft p_width * 1 + p_width_move - p_width '셀크기 단위로 그림 위치 이동

                  .ShapeRange.IncrementLeft border '셀크기 단위로 그림 위치 이동

                  .ShapeRange.IncrementTop border '셀크기 단위로 그림 위치 이동

                  .Placement = xlMoveAndSize '사진이 움직일 수 있도록

                  .PrintObject = True        ' 출력 가능

    End With

    'End If

Blank_check:

   'Range(prev_addr).Offset(h_zoom, 0).Select '다음 이름으로 이동

    ActiveCell.Offset(h_zoom, 0).Select '다음 이름으로 이동

    If ActiveCell = "" Then

    gostop = MsgBox("빈칸입니다. 아래칸으로 계속하시겠습니까?", vbYesNo, "Go? Stop?")

    If gostop = vbYes Then GoTo Blank_check

    Else

    gostop = MsgBox("계속 진행하시겠습니까?", vbYesNo, "Go? Stop?")

    If gostop = vbYes Then GoTo Repeat

    End If

'Exit Sub

'Num_error:

'    MsgBox "숫자로 입력하셔야 합니다."

'    GoTo Input_p_heingt

File_error:

    MsgBox "사진화일이 동일 디렉토리에 없거나, 사진화일명과 Symbol 내용이 다릅니다." + Chr(13)

Exit Sub

noname_error:

    MsgBox "Symbol 내용이 비어있습니다."

End Sub

Sub Get_Picture_manual()

    'On Error GoTo File_error

Dim c_path, p_name, r_name, border

c_path = Application.ThisWorkbook.path '현재 문서의 디렉토리

border = 3

Input_p_heingt:         '사진 높이 입력

    h_zoom = 1

   'h_zoom = Application.InputBox(PROMPT:="사진 높이를 입력하세요(사진이 차지하는 행의 수)", Type:=2)

    'If h_zoom = False Then Exit Sub

    'If IsNumeric(h_zoom) = False Then GoTo Num_error

'Repeat:

    prev_addr = ActiveCell.Address             '현재셀주소

'    r_name = Selection.Text                    '현재셀을 사진화일 이름으로 사용

'        If r_name = "" Then GoTo noname_error

'    p_name = r_name + ".jpg"                   '사진화일명 생성

    p_height = Selection.Height                '현재셀의 높이(사진 높이의 기준이 됨)

    p_width = Selection.Offset(0, 0).Width    '현재열의 너비(사진의 폭이됨)

   'p_width = Selection.Offset(0, -1).Width    '전열의 너비(사진의 폭이됨)

    

    

    'Application.Dialogs(xlDialogOpen).Show

    ins = Application.Dialogs(xlDialogInsertPicture).Show

    

   'ActiveSheet.Pictures.Insert(c_path + "\" + p_name).Select

    If ins Then

    With Selection

                  .ShapeRange.LockAspectRatio = msoFalse

                  .ShapeRange.Height = p_height * h_zoom - border * 2 '셀 높이 * 배율

                  .ShapeRange.Width = p_width - border * 2 '셀 너비 단위로 입력

                  .ShapeRange.IncrementLeft p_width * 0 '셀크기 단위로 그림 위치 이동

                  .ShapeRange.IncrementLeft border '셀크기 단위로 그림 위치 이동

                  .ShapeRange.IncrementTop border '셀크기 단위로 그림 위치 이동

                  .Placement = xlMoveAndSize '사진이 움직일 수 있도록

                  .PrintObject = True        ' 출력 가능

    End With

    End If

'    Range(prev_addr).Offset(h_zoom, 0).Select '다음 이름으로 이동

'    gostop = MsgBox("계속하시겠습니까?", vbYesNo, "Go? Stop?")

'    If gostop = vbYes Then GoTo Repeat

    

'Exit Sub

'Num_error:

'    MsgBox "숫자로 입력하셔야 합니다."

'    GoTo Input_p_heingt

'File_error:

'    MsgBox "사진화일이 동일 디렉토리에 없거나, 해당 인물의 사진화일명이 틀렸습니다." + Chr(13) + "(화일 이름은 해당인물의 이름으로 사용바랍니다.)"

'Exit Sub

'noname_error:

'    MsgBox "이름칸이 비어있습니다."

End Sub

'아래는 참고 함수임

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    Dim rngTarget As Range

    Dim blnOk As Boolean

    Dim L, T, W, H

   

    Set rngTarget = Range("b10,g10,b30,g30") '작업범위설정

    If Union(Target, rngTarget).Address = rngTarget.Address Then '선택셀이 작업범위와 같다면

        With Target.MergeArea '선택셀의 크기를 변수에 담구

            L = .Left

            T = .Top

            W = .Width

            H = .Height

        End With

      

        blnOk = Application.Dialogs(xlDialogInsertPicture).Show '사진삽입대화상자

        If blnOk Then '사진을 입력했다면

            With Selection

                .ShapeRange.LockAspectRatio = msoFalse

                .Width = W

                .Height = H

                .Left = L

                .Top = T

                .TopLeftCell.Offset(0, 1).Select '

            End With

        End If

    End If

   

    Set rngTarget = Nothing '개체메모리 지우기

End Sub