Attribute VB_Name = "modOfficeMerge"
Option Explicit
' Æú´õ¼±Åà officeÆÄÀÏÇÕÄ¡±â: Æú´õ ¾È ÇѱÛ(hwp/hwpx)¡¤PDF¡¤Word¡¤Excel¡¤PowerPoint¡¤À̹ÌÁö(jpg/png/bmp/gif) ¸¦
' À̸§¼øÀ¸·Î ÇϳªÀÇ PDF ·Î ÇÕÄ£´Ù. Word ¹®¼­ Çϳª¿¡ Â÷·Ê·Î ³ÖÀº µÚ PDF ·Î ³»º¸³»´Â ¹æ½Ä.
'  - docx/doc, À̹ÌÁö : ¿øº» ±×´ë·Î »ðÀÔ
'  - hwp/hwpx        : Çѱ۷ΠPDF º¯È¯ ÈÄ »ðÀÔ
'  - xls/xlsx/xlsm   : ¿¢¼¿·Î PDF º¯È¯ ÈÄ »ðÀÔ
'  - ppt/pptx        : ½½¶óÀ̵带 PNG ·Î ³»º¸³» ±×¸²À¸·Î »ðÀÔ
'  - pdf             : Word ÀÇ PDF º¯È¯À¸·Î »ðÀÔ (½ºÄµº»¡¤º¹ÀâÇÑ ¼­½ÄÀº ¸ð¾çÀÌ ´Þ¶óÁú ¼ö ÀÖÀ½)
' °á°ú: °°Àº Æú´õÀÇ officeº´ÇÕ_YYYYMMDD_HHMMSS.pdf + 'officeº´ÇÕ °á°ú' ½ÃÆ®

Private Const WD_PAGE_BREAK As Long = 7
Private Const WD_EXPORT_PDF As Long = 17
Private Const WD_ALERTS_NONE As Long = 0
Private Const OUT_PREFIX As String = "officeº´ÇÕ_"

Public Sub OfficeMergeToPdf(control As IRibbonControl)
    Dim fso As Object, folderPath As String, paths() As String, names() As String, kinds() As String
    Dim n As Long, i As Long, wdApp As Object, wdDoc As Object, wordWasOpen As Boolean
    Dim hwp As Object, ppApp As Object, tmpDir As String, savePath As String, t0 As Single
    Dim results() As String, okCount As Long, failCount As Long, rng As Object, endPos As Long

    BX_Trace = "OM:folder"
    With Application.FileDialog(msoFileDialogFolderPicker)
        .title = "PDF Çϳª·Î ÇÕÄ¥ office ÆÄÀϵéÀÌ ÀÖ´Â Æú´õ¸¦ ¼±ÅÃÇϼ¼¿ä"
        If .Show <> -1 Then Exit Sub
        folderPath = .SelectedItems(1)
    End With
    BX_Trace = "OM:collect"
    Set fso = CreateObject("Scripting.FileSystemObject")
    n = OM_Collect(fso, folderPath, paths, names, kinds)
    If n = 0 Then
        MsgBox "¼±ÅÃÇÑ Æú´õ¿¡ ÇÕÄ¥ ÆÄÀÏ(hwp/hwpx/pdf/doc/docx/xls/xlsx/ppt/pptx/jpg/png)ÀÌ ¾ø½À´Ï´Ù.", vbExclamation, "officeÆÄÀÏÇÕÄ¡±â"
        Exit Sub
    End If
    If UI_Choose("officeÆÄÀÏÇÕÄ¡±â", "ÆÄÀÏ " & n & "°³¸¦ À̸§¼øÀ¸·Î PDF Çϳª·Î ÇÕĨ´Ï´Ù." & vbCrLf & _
                 "(Çѱۡ¤¿¢¼¿¡¤PPT´Â º¯È¯À» °ÅÄ¡¹Ç·Î ÆÄÀÏ ¼ö¿¡ µû¶ó ½Ã°£ÀÌ °É¸³´Ï´Ù)", Array("ÇÕÄ¡±â ½ÃÀÛ", "Ãë¼Ò")) <> 1 Then Exit Sub

    BX_Trace = "OM:tmp"
    t0 = Timer
    tmpDir = fso.BuildPath(Environ$("TEMP"), "officemerge_" & Format$(Now, "hhnnss"))
    fso.CreateFolder tmpDir
    ReDim results(1 To n)

    On Error GoTo Fail
    BX_Trace = "OM:word"
    Application.StatusBar = "MS Word Áغñ Áß..."
    On Error Resume Next
    Set wdApp = GetObject(, "Word.Application")
    On Error GoTo Fail
    wordWasOpen = Not (wdApp Is Nothing)
    If wdApp Is Nothing Then Set wdApp = CreateObject("Word.Application")
    If Not wordWasOpen Then wdApp.Visible = False
    wdApp.DisplayAlerts = WD_ALERTS_NONE
    Set wdDoc = wdApp.Documents.Add
    With wdDoc.PageSetup
        .TopMargin = wdApp.CentimetersToPoints(1.5): .BottomMargin = wdApp.CentimetersToPoints(1.5)
        .LeftMargin = wdApp.CentimetersToPoints(1.5): .RightMargin = wdApp.CentimetersToPoints(1.5)
    End With

    For i = 1 To n
        BX_Trace = "OM:file " & i & "/" & n & " " & names(i)
        Application.StatusBar = "office ÆÄÀÏ ÇÕÄ¡´Â Áß " & i & "/" & n & " : " & names(i)
        DoEvents
        endPos = wdDoc.content.End - 1
        If i > 1 Then
            Set rng = wdDoc.Range(endPos, endPos)
            rng.InsertBreak WD_PAGE_BREAK
            endPos = wdDoc.content.End - 1
        End If
        Set rng = wdDoc.Range(endPos, endPos)
        results(i) = OM_InsertOne(wdApp, wdDoc, rng, paths(i), kinds(i), fso, tmpDir, hwp, ppApp)
        If Left$(results(i), 2) = "¼º°ø" Then okCount = okCount + 1 Else failCount = failCount + 1
    Next i

    BX_Trace = "OM:export"
    Application.StatusBar = "PDF ·Î ÀúÀåÇÏ´Â Áß..."
    savePath = fso.BuildPath(folderPath, OUT_PREFIX & Format$(Now, "yyyymmdd_hhnnss") & ".pdf")
    wdDoc.ExportAsFixedFormat OutputFileName:=savePath, ExportFormat:=WD_EXPORT_PDF, OpenAfterExport:=False
    wdDoc.Close SaveChanges:=False
    Set wdDoc = Nothing
    If Not wordWasOpen Then wdApp.Quit SaveChanges:=False
    Set wdApp = Nothing
    OM_Cleanup hwp, ppApp, fso, tmpDir
    Application.StatusBar = False

    BX_Trace = "OM:result"
    OM_WriteResult folderPath, savePath, names, paths, kinds, results, n, fso
    If UI_Choose("officeÆÄÀÏÇÕÄ¡±â ¿Ï·á", "¼º°ø " & okCount & "°³ / ½ÇÆÐ " & failCount & "°³ (" & Format$(Timer - t0, "0.0") & "ÃÊ)" & vbCrLf & vbCrLf & _
                 "ÀúÀå À§Ä¡: " & savePath & vbCrLf & "(ÆÄÀϺ° °á°ú´Â 'officeº´ÇÕ °á°ú' ½ÃÆ®¿¡ ÀÖ½À´Ï´Ù)", Array("ÇÕÄ£ PDF ¿­±â", "´Ý±â")) = 1 Then
        Shell "explorer """ & savePath & """", vbNormalFocus
    End If
    Exit Sub
Fail:
    Dim em As String: em = Err.Description & " @" & BX_Trace
    On Error Resume Next
    Application.StatusBar = False
    If Not wdDoc Is Nothing Then wdDoc.Close SaveChanges:=False
    If Not wdApp Is Nothing And Not wordWasOpen Then wdApp.Quit SaveChanges:=False
    OM_Cleanup hwp, ppApp, fso, tmpDir
    MsgBox "office ÆÄÀÏ ÇÕÄ¡±â Áß ¿À·ù°¡ ³µ½À´Ï´Ù." & vbCrLf & vbCrLf & em & vbCrLf & vbCrLf & _
           "MS Word °¡ ¼³Ä¡µÇ¾î ÀÖ¾î¾ß Çϸç, Çѱۡ¤PowerPoint ÆÄÀÏÀº ÇØ´ç ÇÁ·Î±×·¥ÀÌ ÇÊ¿äÇÕ´Ï´Ù.", vbCritical, "officeÆÄÀÏÇÕÄ¡±â"
End Sub

' ´ë»ó ÆÄÀÏ ¼öÁý (À̸§¼ø Á¤·Ä, ÀÌÀü º´ÇÕº»¡¤ÀÓ½ÃÆÄÀÏ Á¦¿Ü). kinds: doc/img/pdf/hwp/xls/ppt
Private Function OM_Collect(fso As Object, ByVal folderPath As String, ByRef paths() As String, ByRef names() As String, ByRef kinds() As String) As Long
    Dim f As Object, ext As String, k As String, cnt As Long, i As Long, j As Long, T As String
    For Each f In fso.GetFolder(folderPath).files
        k = OM_Kind(LCase$(fso.GetExtensionName(f.name)))
        If Len(k) > 0 And Left$(f.name, 2) <> "~$" And Left$(f.name, Len(OUT_PREFIX)) <> OUT_PREFIX And Left$(f.name, 3) <> "º´ÇÕ_" Then
            cnt = cnt + 1
            ReDim Preserve paths(1 To cnt): ReDim Preserve names(1 To cnt): ReDim Preserve kinds(1 To cnt)
            paths(cnt) = f.path: names(cnt) = f.name: kinds(cnt) = k
        End If
    Next f
    For i = 1 To cnt - 1
        For j = 1 To cnt - i
            If StrComp(names(j), names(j + 1), vbTextCompare) > 0 Then
                T = paths(j): paths(j) = paths(j + 1): paths(j + 1) = T
                T = names(j): names(j) = names(j + 1): names(j + 1) = T
                T = kinds(j): kinds(j) = kinds(j + 1): kinds(j + 1) = T
            End If
        Next j
    Next i
    OM_Collect = cnt
End Function

Private Function OM_Kind(ByVal ext As String) As String
    Select Case ext
        Case "doc", "docx", "rtf": OM_Kind = "doc"
        Case "jpg", "jpeg", "png", "bmp", "gif", "tif", "tiff": OM_Kind = "img"
        Case "pdf": OM_Kind = "pdf"
        Case "hwp", "hwpx": OM_Kind = "hwp"
        Case "xls", "xlsx", "xlsm": OM_Kind = "xls"
        Case "ppt", "pptx": OM_Kind = "ppt"
    End Select
End Function

' ÆÄÀÏ 1°³¸¦ Word ¹®¼­ ³¡(rng)¿¡ »ðÀÔ. ¹Ýȯ: "¼º°ø" ¶Ç´Â "½ÇÆÐ: ÀÌÀ¯"
Private Function OM_InsertOne(wdApp As Object, wdDoc As Object, rng As Object, ByVal p As String, ByVal kind As String, _
                              fso As Object, ByVal tmpDir As String, ByRef hwp As Object, ByRef ppApp As Object) As String
    Dim tmpPdf As String, k As Long, sld As Object, pres As Object, png As String, wb As Object, tmpCount As Long
    On Error GoTo EH
    Select Case kind
        Case "doc"
            rng.InsertFile fileName:=p, ConfirmConversions:=False
            OM_InsertOne = "¼º°ø"
        Case "img"
            OM_AddPicture wdApp, wdDoc, rng, p
            OM_InsertOne = "¼º°ø"
        Case "pdf"
            OM_InsertOne = OM_InsertPdf(wdApp, wdDoc, rng, p)
        Case "hwp"
            If hwp Is Nothing Then
                On Error Resume Next
                Set hwp = CreateObject("HWPFrame.HwpObject")
                If Not hwp Is Nothing Then
                    hwp.RegisterModule "FilePathCheckDLL", "FilePathCheckerModule"
                    hwp.XHwpWindows.item(0).Visible = False
                End If
                On Error GoTo EH
            End If
            If hwp Is Nothing Then OM_InsertOne = "½ÇÆÐ: ÇѱÛ(HWP) ÇÁ·Î±×·¥ ¾øÀ½": Exit Function
            tmpPdf = fso.BuildPath(tmpDir, fso.GetBaseName(p) & "_" & Format$(Timer * 100, "0") & ".pdf")
            If (hwp.Open(p, "", "forceopen:true") <> 0) Then
                If (hwp.SaveAs(tmpPdf, "PDF", "") <> 0) And fso.FileExists(tmpPdf) Then
                    OM_InsertOne = OM_InsertPdf(wdApp, wdDoc, rng, tmpPdf)
                Else
                    OM_InsertOne = "½ÇÆÐ: ÇÑ±Û PDF º¯È¯ ½ÇÆÐ"
                End If
                hwp.Clear 1
            Else
                OM_InsertOne = "½ÇÆÐ: ÇÑ±Û ÆÄÀÏ ¿­±â ½ÇÆÐ"
            End If
        Case "xls"
            tmpPdf = fso.BuildPath(tmpDir, fso.GetBaseName(p) & "_" & Format$(Timer * 100, "0") & ".pdf")
            Set wb = Application.Workbooks.Open(p, ReadOnly:=True, UpdateLinks:=0)
            wb.ExportAsFixedFormat Type:=xlTypePDF, fileName:=tmpPdf, OpenAfterPublish:=False
            wb.Close SaveChanges:=False
            OM_InsertOne = OM_InsertPdf(wdApp, wdDoc, rng, tmpPdf)
        Case "ppt"
            If ppApp Is Nothing Then Set ppApp = CreateObject("PowerPoint.Application")
            Set pres = ppApp.Presentations.Open(p, True, False, False)   ' ReadOnly, Untitled, WithWindow
            For k = 1 To pres.Slides.Count
                png = fso.BuildPath(tmpDir, fso.GetBaseName(p) & "_s" & Format$(k, "000") & ".png")
                pres.Slides(k).Export png, "PNG", 1600
                If k > 1 Then
                    Set rng = wdDoc.Range(wdDoc.content.End - 1, wdDoc.content.End - 1)
                    rng.InsertBreak WD_PAGE_BREAK
                End If
                Set rng = wdDoc.Range(wdDoc.content.End - 1, wdDoc.content.End - 1)
                OM_AddPicture wdApp, wdDoc, rng, png
            Next k
            pres.Close
            OM_InsertOne = "¼º°ø (" & k - 1 & "Àå)"
        Case Else
            OM_InsertOne = "½ÇÆÐ: Áö¿øÇÏÁö ¾Ê´Â Çü½Ä"
    End Select
    Exit Function
EH:
    OM_InsertOne = "½ÇÆÐ: " & Err.Description
    On Error Resume Next
    If Not pres Is Nothing Then pres.Close
    If Not wb Is Nothing Then wb.Close SaveChanges:=False
End Function

' PDF »ðÀÔ: InsertFile ÀÌ ¾È µÇ¸é ¹®¼­·Î ¿­¾î º¹»ç/ºÙ¿©³Ö±â
Private Function OM_InsertPdf(wdApp As Object, wdDoc As Object, rng As Object, ByVal p As String) As String
    Dim tmpDoc As Object
    On Error Resume Next
    Err.Clear
    rng.InsertFile fileName:=p, ConfirmConversions:=False
    If Err.Number = 0 Then OM_InsertPdf = "¼º°ø": Exit Function
    Err.Clear
    Set tmpDoc = wdApp.Documents.Open(fileName:=p, ConfirmConversions:=False, ReadOnly:=True, Visible:=False)
    If tmpDoc Is Nothing Or Err.Number <> 0 Then OM_InsertPdf = "½ÇÆÐ: PDF º¯È¯ ºÒ°¡ (" & Err.Description & ")": Exit Function
    tmpDoc.content.Copy
    Set rng = wdDoc.Range(wdDoc.content.End - 1, wdDoc.content.End - 1)
    rng.Paste
    tmpDoc.Close SaveChanges:=False
    If Err.Number = 0 Then OM_InsertPdf = "¼º°ø" Else OM_InsertPdf = "½ÇÆÐ: " & Err.Description
End Function

' ±×¸²À» ÆäÀÌÁö Æø¿¡ ¸ÂÃç »ðÀÔ
Private Sub OM_AddPicture(wdApp As Object, wdDoc As Object, rng As Object, ByVal p As String)
    Dim shp As Object, maxW As Single, maxH As Single, r As Single
    With wdDoc.PageSetup
        maxW = .pageWidth - .LeftMargin - .RightMargin
        maxH = .PageHeight - .TopMargin - .BottomMargin - 6
    End With
    Set shp = rng.InlineShapes.AddPicture(fileName:=p, LinkToFile:=False, SaveWithDocument:=True, Range:=rng)
    shp.LockAspectRatio = True
    r = 1
    If shp.Width > maxW Then r = maxW / shp.Width
    If shp.Height * r > maxH Then r = maxH / shp.Height
    If r < 1 Then shp.Width = shp.Width * r
End Sub

Private Sub OM_Cleanup(ByRef hwp As Object, ByRef ppApp As Object, fso As Object, ByVal tmpDir As String)
    On Error Resume Next
    If Not hwp Is Nothing Then hwp.Quit: Set hwp = Nothing
    If Not ppApp Is Nothing Then
        If ppApp.Presentations.Count = 0 Then ppApp.Quit
        Set ppApp = Nothing
    End If
    If Len(tmpDir) > 0 Then If fso.FolderExists(tmpDir) Then fso.DeleteFolder tmpDir, True
End Sub

Private Sub OM_WriteResult(ByVal folderPath As String, ByVal savePath As String, names() As String, paths() As String, kinds() As String, results() As String, ByVal n As Long, fso As Object)
    Dim ws As Worksheet, i As Long, r As Long
    On Error Resume Next
    Set ws = ActiveWorkbook.Worksheets("officeº´ÇÕ °á°ú")
    On Error GoTo 0
    If ws Is Nothing Then
        Set ws = ActiveWorkbook.Worksheets.Add(After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count))
        ws.name = "officeº´ÇÕ °á°ú"
    End If
    ws.cells.Clear
    ws.Range("A2").value = "Æú´õ": ws.Hyperlinks.Add anchor:=ws.Range("B2"), Address:=folderPath, TextToDisplay:=folderPath
    ws.Range("A3").value = "ÇÕÄ£ PDF": ws.Hyperlinks.Add anchor:=ws.Range("B3"), Address:=savePath, TextToDisplay:=fso.GetFileName(savePath)
    ws.Range("A5").value = "No.": ws.Range("B5").value = "ÆÄÀϸí (ÇÕÄ£ ¼ø¼­)": ws.Range("C5").value = "À¯Çü": ws.Range("D5").value = "°á°ú"
    With ws.Range("A5:D5")
        .Font.Bold = True: .Interior.color = RGB(220, 230, 241): .HorizontalAlignment = xlCenter
    End With
    ws.Range("A2:A3").Font.Bold = True
    r = 6
    For i = 1 To n
        ws.cells(r, 1).value = i
        ws.Hyperlinks.Add anchor:=ws.cells(r, 2), Address:=paths(i), TextToDisplay:=names(i)
        ws.cells(r, 3).value = kinds(i)
        ws.cells(r, 4).value = results(i)
        If Left$(results(i), 2) <> "¼º°ø" Then ws.cells(r, 4).Font.color = RGB(255, 0, 0)
        r = r + 1
    Next i
    ws.Range(ws.cells(5, 1), ws.cells(r - 1, 4)).Borders.LineStyle = xlContinuous
    ws.Columns("A:D").AutoFit
    ws.Activate
    ws.Range("A1").Select
End Sub