VBA Word: Tự động gộp hàng loạt file vào một file master kèm Headings và Link file, auto resize image

  

 

Gộp file kèm Headings và Link file

Tạo 1 file master word, lưu dưới dạng .DOCM

ALT+F11 mở cửa sổ Microsoft Visual Basic for Applications

1. Chuột phải vào file master, chọn insert=> module

2. Paste các code ở dưới đây vào Module, dùng sub nào tùy nhu cầu:

- Sub MergeFiles_LatestToTop():insert những nội dung mới vào đầu trang

- Sub MergeFiles_WithDateNameAndLink():insert những nội dung mới vào cuối trang

 

 

Sub MergeFiles_LatestToTop()

    Dim fd As FileDialog

    Dim docCurrent As Document

    Dim fso As Object

    Dim fullPath As Variant

    Dim oFile As Object

   

    Set docCurrent = ActiveDocument

    Set fso = CreateObject("Scripting.FileSystemObject")

    Set fd = Application.FileDialog(msoFileDialogFilePicker)

   

    With fd

        .AllowMultiSelect = True

        .Title = "Select Word files"

        .Filters.Clear

        .Filters.Add "Word Documents", "*.docx; *.doc"

       

        If .Show = -1 Then

            Application.ScreenUpdating = False

           

            'loop through each file

            For Each fullPath In .SelectedItems

                Set oFile = fso.GetFile(fullPath)

               

                Dim createdDate As String

                createdDate = Format(oFile.DateCreated, "yyyy-mm-dd")

                Dim fileNameOnly As String

                fileNameOnly = fso.GetBaseName(fullPath)

               

                'select location

                Selection.HomeKey Unit:=wdStory

                Selection.TypeParagraph

                Selection.HomeKey Unit:=wdStory

               

                'Clear formatting since it inserts in the top

                Selection.ClearFormatting

                Selection.Style = docCurrent.Styles("Normal")

               

                '3: insert HEADING 1

                Selection.Style = docCurrent.Styles("Heading 1")

                Selection.TypeText "[" & createdDate & "] " & fileNameOnly

                Selection.TypeParagraph

                Selection.Style = docCurrent.Styles("Normal")

               

                ' insert Link file

                docCurrent.Hyperlinks.Add Anchor:=Selection.Range, _

                    Address:=fullPath, _

                    TextToDisplay:="Link file"

                Selection.TypeParagraph

               

                'insert file content

                Selection.InsertFile fileName:=fullPath

                Selection.InsertBreak Type:=wdPageBreak

               

            Next fullPath

           

            Application.ScreenUpdating = True

            MsgBox "Done", vbInformation

        End If

    End With

End Sub

 

 

Sub MergeFiles_WithDateNameAndLink()

    Dim fd As FileDialog

    Dim docCurrent As Document

    Dim fso As Object

    Dim fullPath As Variant

    Dim oFile As Object

 

    Set docCurrent = ActiveDocument

    Set fso = CreateObject("Scripting.FileSystemObject")

 

    'select files

    Set fd = Application.FileDialog(msoFileDialogFilePicker)

    With fd

        .AllowMultiSelect = True

        .Title = "Select word files"

        .Filters.Clear

        .Filters.Add "Word Documents", "*.docx; *.doc"

 

        If .Show = -1 Then

            Application.ScreenUpdating = False

            For Each fullPath In .SelectedItems

                Set oFile = fso.GetFile(fullPath)

                ' get infor

                Dim createdDate As String

                createdDate = Format(oFile.DateCreated, "yyyy-mm-dd")

                Dim fileNameOnly As String

                fileNameOnly = fso.GetBaseName(fullPath)

 

                ' move the location to end of master file

                Selection.EndKey Unit:=wdStory

 

                ' insert heading = created date & file name

                With Selection

                .Text = "[" & createdDate & "] " & fileNameOnly

                    .Style = docCurrent.Styles("Heading 1")

                    .InsertParagraphAfter

                    .Collapse Direction:=wdCollapseEnd

                End With

 

                ' insert file link

            docCurrent.Hyperlinks.Add Anchor:=Selection.Range, _

            Address:=fullPath, _

            TextToDisplay:="Link file"

                Selection.InsertParagraphAfter

 

               Selection.Collapse Direction:=wdCollapseEnd

 

                '  insert file content

                Selection.InsertFile fileName:=fullPath

 

                ' add blank line

                Selection.InsertParagraphAfter

 

            Next fullPath

            Application.ScreenUpdating = True

            MsgBox "Done insert files", vbInformation

        End If

    End With

End Sub

 

 

 

Chạy Macro:

1-Bấm icon Run hoặc F5 ở cửa số VBA

Hoặc

2-Tại cửa sổ word, vào developer =>Macros=>chọn Macro=>Run

 

Sau khi nhấn Run (hoặc phím F5), cửa sổ chọn file sẽ xuất hiện. Thực hiện chọn các file cần gộp và nhấn OK

 Lưu ý: thứ tự insert= thứ tự sort file tại cửa sổ chọn

KẾT QUÁ:

- Sub MergeFiles_WithDateNameAndLink():insert những nội dung mới vào cuối trang

 

- Sub MergeFiles_LatestToTop():insert những nội dung mới vào đầu trang

Auto resize image

Khi copy content vào file word, sẽ gặp tình huống file hình lớn quá kích thước trang

Mở cửa số VBA, copy và run code dưới để chỉnh lại image width của toàn bộ hình trong file:

Sub ResizeAllPictures()

    Dim shp As InlineShape

    Dim targetWidth As Single

    ' set width

    targetWidth = 7 * 72

'=> 7 = 7inch, 72 =72 point, đổi số inch nếu cần

   

    'Loop through all Inline shapes in current DOC

    For Each shp In ActiveDocument.InlineShapes

        shp.LockAspectRatio = msoTrue ' Keep the ratio

        shp.Width = targetWidth

    Next shp

  'Loop through all floating shapes in current DOC

    Dim s As Shape

    For Each s In ActiveDocument.Shapes

        s.LockAspectRatio = msoTrue

        s.Width = targetWidth

    Next s

    MsgBox "Changed images width!"

End Sub