Work area

  1. Buka MS Word
  2. Tekan Alt + F11
  3. Kemudian Copy & Paste Kod Ini dan klik F5 untuk memulakan proses memasukkan serta auto format gambar

Sub AddPics() 
    Application.ScreenUpdating = False 
    Dim oTbl As Table, i As Long, j As Long, k As Long, StrTxt As String 
     'Select and insert the Pics
    With Application.FileDialog(msoFileDialogFilePicker) 
        .Title = "Select image files and click OK" 
        .Filters.Add "Images", "*.gif; *.jpg; *.jpeg; *.bmp; *.tif; *.png" 
        .FilterIndex = 2 
        If .Show = -1 Then 
             'Add a 2-row by 2-column table with 7cm columns to take the images
            Set oTbl = Selection.Tables.Add(Selection.Range, 2, 2) 
            With oTbl 
                .AutoFitBehavior (wdAutoFitFixed) 
                .Columns.Width = CentimetersToPoints(7) 
                 'Format the rows
                Call FormatRows(oTbl, 1) 
            End With 
            CaptionLabels.Add Name:="Picture" 
            For i = 1 To .SelectedItems.Count 
                j = Int((i + 1) / 2) * 2 - 1 
                k = (i - 1) Mod 2 + 1 
                 'Add extra rows as needed
                If j > oTbl.Rows.Count Then 
                    Call FormatRows(oTbl, j) 
                End If 
                 'Insert the Picture
                ActiveDocument.InlineShapes.AddPicture _ 
                FileName:=.SelectedItems(i), LinkToFile:=False, _ 
                SaveWithDocument:=True, Range:=oTbl.Rows(j).Cells(k).Range 
                 'Get the Image name for the Caption
                StrTxt = Split(.SelectedItems(i), "")(UBound(Split(.SelectedItems(i), ""))) 
                StrTxt = ": " & Split(StrTxt, ".")(0) 
                 'Insert the Caption on the row below the picture
                With oTbl.Rows(j + 1).Cells(k).Range 
                    .InsertBefore vbCr 
                    .Characters.First.InsertCaption _ 
                    Label:="Picture", Title:=StrTxt, _ 
                    Position:=wdCaptionPositionBelow, ExcludeLabel:=False 
                    .Characters.First = vbNullString 
                    .Characters.Last.Previous = vbNullString 
                End With 
        End If 
    End With 
    Application.ScreenUpdating = True 
End Sub 
Sub FormatRows(oTbl As Table, x As Long) 
    With oTbl 
        With .Rows(x) 
            .Height = CentimetersToPoints(7) 
            .HeightRule = wdRowHeightExactly 
            .Range.Style = "Normal" 
        End With 
        With .Rows(x + 1) 
            .Height = CentimetersToPoints(0.75) 
            .HeightRule = wdRowHeightExactly 
            .Range.Style = "Caption" 
        End With 
    End With 
End Sub 



Incoming search terms:

Recommended Reading

About Tarmizi Sukarno

Im a part time internet marketer, Online Seller, Offline Seller, and Creative Advertiser Implementer. Feel free to contact me at +6011-38800002 for free consultations to improve your business.