Attribute VB_Name = "Module11"
Sub FontChange()
'Upravil masar
    Dim xDlg As FileDialog
    Dim xFolder As Variant
    Dim xFileStr As String
    Dim xShape As Shape
    Dim xDoc As Document
    Dim txtFont As String
    Dim tvartFont As String
    On Error Resume Next
Set dlg = Dialogs(wdDialogFormatFont)
txtFont = "Arial"
tvarFont = "Arial"
dotaz1:
       I = MsgBox("Chete tento font? " & txtFont, vbYesNo, "Výběr fontu pro texty")
    Select Case I
    Case vbNo
        dlg.Show
        txtFont = Selection.Font.Name
        GoTo dotaz1
    End Select
dotaz2:
       I = MsgBox("Chete tento font pro textová pole? " & tvarFont & vbCrLf & "Zrušit = zachová původní fonty", vbYesNoCancel, "Výběr fontu textových polí")
    Select Case I
    Case vbNo
        dlg.Show
        tvarFont = Selection.Font.Name
        GoTo dotaz2
    Case vbCancel
        tvarFont = "original"
    End Select
 Set xDlg = Application.FileDialog(msoFileDialogFolderPicker)
 If xDlg.Show = -1 Then
    xFolder = xDlg.SelectedItems(1) + "\"
    xFileStr = Dir(xFolder & "*.doc", vbNormal)
While xFileStr <> ""
    Documents.Open xFolder & xFileStr
    Selection.WholeStory
    'Selection.Font.Size = 8
    Selection.Font.Name = txtFont
    If tvarFont = "original" Then
        GoTo Konec
    End If
    Set xDoc = ActiveDocument
    For Each xShape In xDoc.Shapes
        xShape.Select
        If xShape.GroupItems Is Nothing Then
            With xShape.TextFrame.TextRange.Font
            .Name = tvarFont
            '.Size = 20
            End With
            GoTo LblExit
        End If
        For I = 1 To xShape.GroupItems.Count
            With xShape.GroupItems(I).TextFrame.TextRange.Font
                .Name = tvarFont
                '.Size = 20
            End With
        Next
LblExit:
    Next
Konec:
    ActiveDocument.Save
    ActiveDocument.Close
    xFileStr = Dir()
Wend
 End If
End Sub