피피티와 엑셀을 이용한 전자 방명록 (e-guestbook)

전시회나 작품 발표회 때 컴퓨터로 방명록을 작성하는 경우를 위한 자동화도구입니다.

방명록 입력은 파워포인트를 이용하고

방명록 데이터는 엑셀 파일에 저장합니다.

(아이콘은 Flaticon.com 에서 받았습니다.)

성명은 필수이고

이메일은 @를 검사하고

연락처는 처음 두글자가 숫자인지 검사합니다.

원래 파워포인트 TextBox 에는 SetFocus 가 작동하지 않지만

Shyam Pillai 님의 소스를 활용해서 작동하도록 했습니다.

( Textbox Setfocus function is made by Shyam Pillai  -  Shyam@Mvps.Org   http://skp.mvps.org )

저장은 방명록.xlsx 파일에

2번째 줄부터 성명, 이메일, 전화, 메모, 작성 시간 순으로 저장이 됩니다.

기존 자료에 추가되어 바로 아래줄에 추가됩니다.

'https://kin.naver.com/qna/detail.nhn?d1id=1&dirId=102020101&docId=300736954
Option Explicit
Const TITLE = "방명록"
 
Public xlsApp As Object    'New Excel.Application
Public xlsWb As Object     'Workbook
 
Public Sub WriteGuestbook()
 
    Dim sht As Object       'Worksheet
    Dim r As Long
    Dim i As Integer
    Dim user As VbMsgBoxResult
    Dim msg As String
    Dim xlsFile As String
    Dim Labels(1 To 4) As String
    
    On Error GoTo Er
    
    If Len(ActivePresentation.Slides(1).Shapes("TextBox1").OLEFormat.Object.Text) = 0 Then
        MsgBox "성명은 필수항목입니다.", vbOKOnly, TITLE
        ActivateShape.ActivateShape ActivePresentation.Slides(1).Shapes("TextBox1")
        Exit Sub
    End If
    
    Labels(1) = "성명": Labels(2) = "이메일": Labels(3) = "연락처": Labels(4) = "메모"
    
    xlsFile = ActivePresentation.Path & "\방명록.xlsx"
    
    msg = "아래 내용으로 방명록을 남기시겠습니까?"
    For i = 1 To 4
        msg = msg & vbNewLine & vbNewLine & Labels(i) & " : " & _
                ActivePresentation.Slides(1).Shapes("TextBox" & i).OLEFormat.Object.Text
    Next i
  
    user = MsgBox(msg, vbOKCancel, TITLE)
    If user = vbCancel Then Exit Sub
    
    Set xlsApp = CreateObject("Excel.Application")
    If xlsApp Is Nothing Then MsgBox "엑셀 실행 오류", vbOKOnly, TITLE: Exit Sub
    xlsApp.Visible = False
    
    If Len(Dir(xlsFile)) < 1 Then
        Set xlsWb = xlsApp.Workbooks.Add(-4167): 'xlsWb.SaveAs FileName:=xlsFile
        xlsWb.SaveAs FileName:=xlsFile: xlsWb.Close SaveChanges:=False
    End If
    'Else
        Set xlsWb = xlsApp.Workbooks.Open(xlsFile)
    'End If
    Set sht = xlsWb.Worksheets(1)
    
    r = sht.Cells(sht.Rows.Count, 1).End(-4162).Offset(1).Row    '맨 아래줄 다음줄에 추가(-4162=xlUp)
    
    For i = 1 To 4
        sht.Cells(r, i).Value = ActivePresentation.Slides(1).Shapes("TextBox" & i).OLEFormat.Object.Text
    Next i
    sht.Cells(r, i).Value = Format(Date, "YYYY/MM/DD") & Format(Time, " Hh:nn:ss")
    sht.Cells(r, i).NumberFormat = "YYYY/MM/DD hh:mm:ss"
    sht.Columns.AutoFit
    
Er:
    If Err.Number Then MsgBox Err.Description
    If Not (xlsWb Is Nothing) Then
        xlsWb.Save
        'xlsWb.Close SaveChanges:=True, FileName:=xlsFile
        'xlsWb.Saved = True
        xlsWb.Close SaveChanges:=False
    End If
 
    If Not (xlsApp Is Nothing) Then
        xlsApp.Quit
        Set xlsApp = Nothing
        Set xlsWb = Nothing
        Set sht = Nothing
    End If
    
    CancelGuestbook     '기존 내용 지우기
    On Error Resume Next
    SlideShowWindows(1).View.GotoSlide 1, msoTrue
End Sub
 
Public Sub CancelGuestbook()
    Dim i As Integer
    For i = 1 To 4
        ActivePresentation.Slides(1).Shapes("TextBox" & i).OLEFormat.Object.Text = ""
    Next i
End Sub
 
Sub OnSlideShowPageChange(SSW As SlideShowWindow)
    If SSW.View.CurrentShowPosition = 1 Then _
        'FindFirstTextboxControlAndSetFocus (SSW.View.Slide)
        ActivateShape.ActivateShape ActivePresentation.Slides(1).Shapes("TextBox1")
    End If
End Sub
 
Sub OnSlideShowTerminate_notUsed(ByVal Wn As SlideShowWindow)
    If Not (xlsApp Is Nothing) Then
        If Not (xlsWb Is Nothing) Then
            xlsWb.Save
            xlsWb.Close SaveChanges:=False
        End If
        xlsApp.Quit
        Set xlsApp = Nothing
        Set xlsWb = Nothing
        Set sht = Nothing
    End If
End Sub
 

다운받기(Download)

방명록2.pptm

방명록2.ppsm

(방명록.xlsx 는 없는 경우 자동으로 생성됨.)

특히 ppsm 파일의 경우 인터넷에 받은 자료는 탐색기에서 우클릭해서 차단해제 누르고 '확인'을 반드시 눌러주고 매크로를 허용하여야 합니다. 그렇지 않은 경우 매크로가 허용되지 않아 글씨 입력이나 클릭실행이 전혀 안됩니다.

2018.5.17 수정

보이지 않는 개체가 2개 그룹이 있었는데

2016에서 탭키가 작동하지 않아 모두 삭제하니 이제 동작하네요.