FileSize함수를 이용해 폴더내의 파일 목록을 표시하자

제목대로 폴더를 선택하면

그 폴더 내의 파워포인트 파일목록을  사이즈와 함께 보여줍니다.

매크로 허용해주시고 실행하면

그저 이런 빈화면이 나옵니다.

자동으로 폴더창이 뜨거나, 혹시 안뜨면

아래 처럼 '폴더선택'을 클릭해서 파포 파일들이 들어 있는 폴더를 선택해줍니다.

해당폴더에 들어가서 확인을 클릭해주세요.

ppt 가 많이 들어 있는 폴더가 좋겠지요.

파일이 아니라 폴더를 선택하고 확인하는 것에 유의하세요.

이렇게 막대그래프로 파일용량을 보여줍니다.

약간의 애니메이션도 추가했습니다.

사진파일을 넣을수록 PPT 파일의 용량은 커지지요.

가장 큰 파일을 100%로 기준삼아 보여줍니다.

색깔이 빨간색에 가까울 수록 큰 용량의 파일입니다.

소스상 RGB(255,125,125) 가 100% 로 가장 큰 파일의 색깔입니다.

파일은 확장자의 첫 두 글자가 pp 인 경우에 한해 보여줍니다.

( *.pp* )라서 .ppt .pps .pptm .ppsm 등이 되겠지요.

한 페이지에 5개씩 보여주고

하단의 페이지 옆에 <<  1/2 >> 를 클릭해 이전 페이지와 다음 페이지를 이동할 수 있습니다.

추가로 파포파일을 선택하면 그 파일을 열도록(실행하도록) 했습니다.

(여기서 또 하나 떠오른게 이걸 변형하면 .mp3파일 플레이어를 만들 수도 있겠다는 생각이 드네요.)

소스는 Alt-F11로 열어보시기 바랍니다.

처음 폴더 선택하는 Shape 를 제외하고는

모두 VBA로 생성하다보니

별거 아니지만 소스가 꽤 길어지더군요.

VBA로 개체(shape) 생성, 복사하는 것이나

개체에 애니메이션을 걸거나, 텍스를 바꾸는 것,

폴더의 파일을 검색하는 것,

배열에 파일목록을 저장하는 것 등을

참고하실 수 있습니다.

파일리스트 정렬 기능이 추가된 FileSize_Sort.pptm 을 추가로 올립니다.

파일사이즈와 파일명을 오름차순, 내림차순으로 정렬할 수 있습니다.

'FileSize.pptm

'Search PPT files in the target folder and show each file's size with a bar-type graph

'by konahn(at)naver.com

Option Explicit

Option Base 1

Public Type FileType

    FileName As String              ' 파일명과 파일크기를 가진 새 타입 선언

    FileSize As Long

End Type

Public Target As String

Public FileList() As FileType       ' 파일목록 배열

Public MaxSize As Long              ' 폴더내 가장 큰 파일사이즈

Public Started As Boolean           ' 슬라이드 시작 표시

Public SortBy As Integer            ' 정렬 옵션  0 unsort, 1 sort up by filename, -1 sort down by filename, 2/-2 sort up/down by filesize

Const Margin = 50                   ' 슬라이드 여백

Const TopMargin = 75                ' 화면 여백

Const Height = 25                   ' 막대 등의 높이

'시작

Sub Start()

    CheckSortOption     ' 정렬 옵션 체크

    

    EraseAll            ' 기존 슬라이드와 개체 모두 지우기

       

    Target = GetFolder  ' 폴더를 선택

   

    ScanDir             ' 파일 검색

    

    If SortBy <> 0 Then SortFileList

    

    DrawGraph           ' 막대그래프 그리기

        

End Sub

Sub SortNow()

    If UBound(FileList) < 1 Then

        MsgBox "먼저 폴더를 선택하세요", vbCritical

        Exit Sub

    End If

    ActivePresentation.SlideShowWindow.View.GotoSlide 1

    CheckSortOption

    EraseAll

    If SortBy = 0 Then ScanDir Else SortFileList

    DrawGraph

End Sub

Sub SortFileList()

    Dim i As Integer, j As Integer

    For i = 1 To UBound(FileList) - 1

        For j = i + 1 To UBound(FileList)

            Select Case SortBy

                Case 1

                    If FileList(i).FileName > FileList(j).FileName Then Call SwitchList(i, j)

                Case -1

                    If FileList(i).FileName < FileList(j).FileName Then Call SwitchList(i, j)

                Case 2

                    If FileList(i).FileSize > FileList(j).FileSize Then Call SwitchList(i, j)

                Case -2

                    If FileList(i).FileSize < FileList(j).FileSize Then Call SwitchList(i, j)

                Case Else

            End Select

        Next j

    Next i

End Sub

Sub SwitchList(a As Integer, b As Integer)

    Dim temp As FileType

    temp = FileList(a)

    FileList(a) = FileList(b)

    FileList(b) = temp

End Sub

'정렬 옵션에 따라 화면에 체크 표시

Sub CheckSortOption()

    Dim i As Integer

    If SortBy < -2 Or SortBy > 2 Then SortBy = 0

    With ActivePresentation.Slides(ActivePresentation.SlideShowWindow.View.CurrentShowPosition)

        For i = 0 To 2

            If i = Abs(SortBy) Then .Shapes("Dir_SortBy" & i).GroupItems("Circle").Fill.ForeColor.RGB = rgbDodgerBlue _

            Else .Shapes("Dir_SortBy" & i).GroupItems("Circle").Fill.ForeColor.RGB = rgbWhite

        Next i

        If SortBy = 0 Then

            .Shapes("Dir_SortUp").GroupItems("Circle").Fill.ForeColor.RGB = rgbWhite

            .Shapes("Dir_SortDown").GroupItems("Circle").Fill.ForeColor.RGB = rgbWhite

        ElseIf SortBy > 0 Then

            .Shapes("Dir_SortUp").GroupItems("Circle").Fill.ForeColor.RGB = rgbDodgerBlue

            .Shapes("Dir_SortDown").GroupItems("Circle").Fill.ForeColor.RGB = rgbWhite

        ElseIf SortBy < 0 Then

            .Shapes("Dir_SortUp").GroupItems("Circle").Fill.ForeColor.RGB = rgbWhite

            .Shapes("Dir_SortDown").GroupItems("Circle").Fill.ForeColor.RGB = rgbDodgerBlue

        End If

    End With

End Sub

'클릭시 정렬옵션 변경

Sub ClickOption(shp As Shape)

'MsgBox shp.ParentGroup.Name

    If Left(shp.ParentGroup.Name, 10) = "Dir_SortBy" Then

        SortBy = CInt(Mid(shp.ParentGroup.Name, 11))    ' 0, 1, 2

    ElseIf shp.ParentGroup.Name = "Dir_SortUp" Then     ' up

        SortBy = Abs(SortBy)

    ElseIf shp.ParentGroup.Name = "Dir_SortDown" Then   ' down

        SortBy = -1 * Abs(SortBy)

    End If

    CheckSortOption

End Sub

'기존 슬라이드와 개체 모두 지우기

Sub EraseAll()

    Dim sld As Slide

    Dim i As Integer

    '2번 슬라이드부터 끝까지 삭제

    For i = ActivePresentation.Slides.count To 2 Step -1

        If i > 1 Then ActivePresentation.Slides(i).Delete

    Next i

    '1번 슬라이드에서 폴더명 제외하고 삭제

    With ActivePresentation.Slides(1)

        For i = .Shapes.count To 1 Step -1

            If Left(.Shapes(i).Name, 4) <> "Dir_" Then .Shapes(i).Delete

        Next

    End With

End Sub

'그래프 그리기

Sub DrawGraph()

    Dim SlideNo As Integer

    Dim sld As Slide

    Dim myLayout As CustomLayout

    Dim shp As Shape

    Dim eft As Effect

    Dim MW As Single, MH As Single

    Dim x As Single, y As Single, w As Single

    Dim i As Integer

    

    MW = ActivePresentation.PageSetup.SlideWidth

    MH = ActivePresentation.PageSetup.SlideHeight

    SlideNo = 1

    For i = 1 To UBound(FileList)

        With ActivePresentation.Slides(SlideNo).Shapes

            x = Margin

            y = Margin + TopMargin + ((i - 1) Mod 5) * Height * 3

            w = MW - Margin * 2

            '페이지 번호 표시

            If i Mod 5 = 1 Then

                Set shp = .AddTextbox(msoTextOrientationHorizontal, MW \ 2 - Height, MH - Margin, Margin + Height, Height)

                shp.TextFrame.TextRange.Text = SlideNo & "/" & ((UBound(FileList) + 4) \ 5)

                shp.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignCenter

                shp.Name = "Page" & SlideNo

            End If

            '파일명 표시

            Set shp = .AddTextbox(msoTextOrientationHorizontal, x, y, w, Height)

            shp.TextFrame.TextRange.Text = FileList(i).FileName

            shp.TextFrame.WordWrap = msoFalse

            shp.Name = "file" & i

            shp.ActionSettings(ppMouseClick).Action = ppActionRunMacro

            shp.ActionSettings(ppMouseClick).Run = "RunPPT"     '클릭시 PPT 불러오기

            '막대그래프 표시

            y = y + Height

            w = w * FileList(i).FileSize / MaxSize     ' Filesize * 1/100

            Set shp = .AddShape(msoShapeRoundedRectangle, x, y, w, Height)

            shp.Adjustments(1) = 1  '둥글게

            shp.Fill.ForeColor.RGB = RGB(255 * (w / (MW - Margin * 2)), 125, 125)

            shp.Name = "bar" & i

            'animation 추가

            Set eft = ActivePresentation.Slides(SlideNo).TimeLine.MainSequence.AddEffect(shp, _

            msoAnimEffectFly, , msoAnimTriggerAfterPrevious, -1)  'msoAnimEffectExpand

            eft.EffectParameters.Direction = msoAnimDirectionRight

            eft.Timing.Duration = 0.25

            

            '막대그래프 위에 파일사이즈 표시

            w = MW - Margin * 2

            Set shp = .AddTextbox(msoTextOrientationHorizontal, x, y, w, Height)

            shp.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignRight

            shp.TextFrame.WordWrap = msoFalse

            shp.TextFrame.TextRange.Text = Format(FileList(i).FileSize, "0,000 bytes")

            shp.Name = "size" & i

            If i Mod 5 = 0 Then                     ' 5,10,15..5의 배수마다 새로운 슬라이드 추가

                '이전 페이지 하단 다음페이지버튼 추가

                Set shp = .AddTextbox(msoTextOrientationHorizontal, MW \ 2 + Margin, MH - Margin, Margin, Height)

                shp.TextFrame.TextRange.Text = ">>"

                shp.Name = "MoveR" & SlideNo

                shp.ActionSettings(ppMouseClick).Action = ppActionNextSlide '애니매이션을 유지하려면 gotoSlide 를 이용

                '슬라이드 추가

                Set myLayout = ActivePresentation.Slides(SlideNo).CustomLayout

                SlideNo = SlideNo + 1

                Set sld = ActivePresentation.Slides.AddSlide(SlideNo, myLayout)

                '폴더명 표시, 정렬옵션 등 복사

                For Each shp In ActivePresentation.Slides(1).Shapes

                    If Left(shp.Name, 4) = "Dir_" Then

                        shp.Copy

                        With ActivePresentation.Slides(SlideNo).Shapes.Paste

                            'Group 을 복사하면 Parent/Child 성질을 잃어버리는 버그(?)를 보완

                            If shp.Type = msoGroup Then .Ungroup.Regroup.Name = shp.Name

                        End With

                    End If

                Next shp

                '새 페이지 하단 이전페이지버튼 추가

                Set shp = ActivePresentation.Slides(SlideNo).Shapes.AddTextbox(msoTextOrientationHorizontal, _

                MW \ 2 - Margin - Height, MH - Margin, Margin, Height)

                shp.TextFrame.TextRange.Text = "<<"

                shp.Name = "MoveL" & SlideNo

                shp.ActionSettings(ppMouseClick).Action = ppActionPreviousSlide

            End If

        End With

    Next i

End Sub

'textbox에 쓰여 있는 ppt 열기

Sub RunPPT(shp As Shape)

        Presentations.Open (Target & "\" & shp.TextFrame.TextRange.Text)

End Sub

'폴더안 파일을 검색

Sub ScanDir()

    Dim myFile As String

    Dim count As Integer

    

    With ActivePresentation.Slides(1).Shapes("Dir_Name").TextFrame

        .TextRange.Text = Target

        .WordWrap = msoFalse

    End With

    

    '배열 삭제

    Erase FileList

    'search for ppt files

    count = 0

    MaxSize = 0

    myFile = Dir(Target & "\*.pp*")                                 ' .ppt, .pps, .pptm, .ppsm ...

    Do While myFile <> ""

        'MsgBox myFile & ":" & FileLen(Target & "\" & myFile)

        count = count + 1

        ReDim Preserve FileList(1 To count)

        

        'save filename and filesize

        FileList(count).FileName = myFile

        FileList(count).FileSize = FileLen(Target & "\" & myFile)

        If FileList(count).FileSize > MaxSize Then MaxSize = FileList(count).FileSize   ' 가장 큰 파일 크기를 구함

        myFile = Dir

    Loop

    

End Sub

' 폴더명을 선택

Function GetFolder() As String

    Dim fileNo As Integer

    Dim fd As FileDialog

    Dim Target As String

    Set fd = Application.FileDialog(msoFileDialogFolderPicker)      '파일은 msoFileDialogFilePicker

    With fd

        .Title = "PPT가 있는 폴더를 선택하세요."

        .Filters.Clear

        .InitialFileName = ActivePresentation.Path & "\"            '바탕화면은 Environ("USERPROFILE") & "\Desktop\"

        .AllowMultiSelect = False

        If .Show = True Then Target = .SelectedItems(1)

    End With

    Set fd = Nothing

    GetFolder = Target

End Function

'슬라이드쇼 시작시 자동으로 매크로 시작

Sub OnSlideShowPageChange(ByVal SSW As SlideShowWindow)

    If Started Then Exit Sub

    If SSW.View.CurrentShowPosition = 1 Then

    'MsgBox "first time"

        Started = True

        Start

    End If

End Sub

Sub OnSlideShowTerminate(ByVal SSW As SlideShowWindow)

    Started = False

End Sub

'개체(Shape)의 위치 등을 알아보기 위한 용도

Sub GetXYSize()

    Dim x As Single, y As Single, w As Single, h As Single

    With ActivePresentation.Slides(1).Shapes("Dir_Name")

    x = .Left

    y = .Top

    w = .Width

    h = .Height

    

    MsgBox "x:" & x & " y:" & y & " w:" & w & " h:" & h & " line color:" & .Line.ForeColor.RGB

    End With

End Sub

http://cafe.naver.com/gameppt/124075

FileSize.pptm

FileSize_Sort.pptm