Application.Keyboard wdRussian

Application.Keyboard wdEnglishUS

If (Application.Keyboard And wdRussian) = wdRussian Then
    MsgBox "RU"
Else
    MsgBox "EN"
End If

Public Sub CreateInformationInTable()

    Dim objDoc As Word.Document
    Dim objSel As Word.Selection
    Dim objBookmark As Word.Bookmark
    Dim objTable As Word.Table, iAddress$

    Set objSel = Selection 'Application.Selection

    If objSel.Information(wdWithInTable) = True Then
       Application.ScreenUpdating = False

       Set objDoc = ActiveDocument
       Set objBookmark = objDoc.Bookmarks.Add("ТаблицаX", objSel)
       Set objTable = objDoc.Tables.Add(objDoc.Sections.Add.Range, 5, 2)

       iAddress = "ТаблицаX " & getTableAddress(objSel)

       objTable.Cell(1, 1).Range.Text = "Сумма :"
       objTable.Cell(1, 2).Formula "=SUM(" & iAddress & ")"

       objTable.Cell(2, 1).Range.Text = "Количество :"
       objTable.Cell(2, 2).Formula "=COUNT(" & iAddress & ")"

       objTable.Cell(3, 1).Range.Text = "Минимум :"
       objTable.Cell(3, 2).Formula "=MIN(" & iAddress & ")"

       objTable.Cell(4, 1).Range.Text = "Максимум :"
       objTable.Cell(4, 2).Formula "=MAX(" & iAddress & ")"

       objTable.Cell(5, 1).Range.Text = "Среднее :"
       objTable.Cell(5, 2).Formula "=AVERAGE(" & iAddress & ")"

       objBookmark.Delete: objTable.Select 'необязательно

       Application.ScreenUpdating = True
    Else

       MsgBox "Выделите таблицу или часть таблицы ... но не более"
    End If

End Sub

Private Function getTableAddress$(objSel As Word.Selection)

    getTableAddress = Chr( _
    objSel.Columns.First.Index + 64) & _
    objSel.Rows.First.Index & ":" & Chr( _
    objSel.Columns.Last.Index + 64) & _
    objSel.Rows.Last.Index

End Function

Private Sub OpenUnvisibleDocument()
    Dim iFileName$, objDoc As Word.Document
    
    iFileName = "C:\Имя_документа.doc"
    Set objDoc = GetObject(iFileName) ', "Word.Document")
    
    'Здесь Вы можете работать с невидимым (на экране) документом
    
    objDoc.Close saveChanges:=wdSaveChanges
    'wdDoNotSaveChanges - закрыть без изменений
End Sub

Private Sub OpenUnvisibleDocument2() 'Word 2000(и старше)
    Dim iFileName$, objDoc As Word.Document
    
    iFileName = "C:\Имя_документа.doc"
    Set objDoc = Documents.Open(FileName:=iFileName, Visible:=False)
    
    'Здесь Вы можете работать с невидимым (на экране) документом
    
    objDoc.Close saveChanges:=wdSaveChanges
    'wdDoNotSaveChanges - закрыть без изменений
End Sub

Private Sub OpenUnvisibleDocument3()
    Dim iFileName$: iFileName = "C:\Имя_документа.doc"
    
    Application.ScreenUpdating = False
    With Documents.Open(FileName:=iFileName)
         'Здесь Вы можете работать с этим доком
         .Close saveChanges:=wdDoNotSaveChanges
         'wdSaveChanges сохранить все изменения
    End With
    Application.ScreenUpdating = True
End Sub

Private Sub ImportGraphicOutFolder()
    Dim iPath$, iFileName$
    Dim objDoc As Word.Document, objAnchor As Word.Range
   
    iPath = "C:\Pictures\" 'Укажите свою папку с завершающим слэшем
    iFileName = Dir(iPath)
   
    If iFileName <> "" Then
       'On Error Resume Next       
       Set objDoc = Documents.Add: Set objAnchor = objDoc.Range(0)
       Do
            objDoc.InlineShapes.AddPicture iPath & iFileName, False, True, objAnchor
            Set objAnchor = objDoc.Range(objDoc.Range.End - 1)
            iFileName = Dir
       Loop Until iFileName = ""
       'Kill iPath & "*"
    Else
       MsgBox "Импорт невозможен", vbCritical, ""
    End If
End Sub

Private Sub FindWindowCaption()
    If Not Tasks.Exists("Microsoft Excel") Then
       Shell "Excel.exe", vbNormalFocus
    Else
       With Tasks("Microsoft Excel")
            .Activate
            .WindowState = wdWindowStateMaximize
       End With
    End If
End Sub

Private Sub ExampleRunExcel()
    On Error Resume Next
    Dim objXL As Object
    Set objXL = GetObject(, "Excel.Application")
    
    If objXL Is Nothing Then
       Shell "Excel.exe", vbNormalFocus
    Else
       objXL.WindowState = -4137 'xlMaximized
       AppActivate objXL.Caption
    End If
End Sub

Private Sub FindWindowCaption2()
    If Not Tasks.Exists("Калькулятор") Then
       Shell "Calc.exe", vbNormalFocus
    Else
       Tasks("Калькулятор").Activate
    End If
End Sub

Private Sub FindOpenTextFileAndClose()
    Dim objTask As Word.Task
    For Each objTask In Tasks
        If InStr(objTask.Name, "Блокнот") > 0 Then
           objTask.SendWindowMessage 273&, 3&, 0&
           objTask.Close
        End If
    Next
End Sub

Private Sub FindOpenTextFileAndClose2()
    Dim objTask As Word.Task
    For Each objTask In Tasks
        If LCase(objTask.Name) Like "*.txt*" Then
           objTask.SendWindowMessage 273&, 3&, 0&
           objTask.Close
        End If
    Next
End Sub

Private Sub CreateListTasks()
    Dim objAnchor As Word.Range
    Dim objTask As Word.Task, iRow%: iRow = 1
    
    Set objAnchor = Documents.Add.Range
    With objAnchor.Tables.Add(objAnchor, Tasks.Count + 1, 3, wdWord9TableBehavior)
         '.Style = wdStyleTableColorfulList 'Word 2007
         .Rows(iRow).Range.Bold = True
         .Cell(iRow, 1).Range = "#"
         .Cell(iRow, 2).Range = "Task Name"
         .Cell(iRow, 3).Range = "Visible"
         
         For Each objTask In Tasks
             iRow = iRow + 1
             .Cell(iRow, 1).Range = iRow - 1
             .Cell(iRow, 2).Range = objTask.Name
             .Cell(iRow, 3).Range = objTask.Visible
         Next
         .Columns.AutoFit
    End With
End Sub