Запустите VBA на любой PowerPoint, чтобы изменить LanguageID

Question

Я пытаюсь создать панель инструментов с кнопкой, которая изменит LanguageID для всех фигур и текстовых полей в документе PowerPoint на EnglishUS. Это необходимо для устранения проблемы, когда, если кто-то проверяет орфографию документа, используя другой язык (в данном случае французский), этот язык внедряется в сам файл .ppt. Когда другой пользователь пытается проверить правописание в той же области, используя другой язык, например английский, слова, предлагаемые программой проверки правописания, находятся на языке оригинала. Например, он попытался исправить слово «указанный» на «конкретизировать», французское слово. Из того, что я прочитал, единственный способ исправить эту проблему с языком - это использовать VBscript, а единственный способ запустить VBscript в Powerpoint без встраивания его в .ppt и каждый раз загружать этот файл - создать надстройку с кнопкой на панели инструментов для запуска макроса, также используя VBS. Ниже приведен код, который я взял из разных источников, и когда я попытался собрать его, он не работал (хотя он компилировался). Если бы кто-то мог взглянуть, я уверен, что это простая синтаксическая ошибка или что-то в этом роде, это была бы ОГРОМНАЯ помощь. Спасибо заранее !!

Кстати, если кто-нибудь знает более простой способ запуска макроса в PPT без необходимости каждый раз открывать определенный PPT, я ВСЕ уши.

и теперь скрипт:

Sub Auto_Open() 
    Dim oToolbar As CommandBar 
     Dim oButton As CommandBarButton 
     Dim MyToolbar As String 

     ''# Give the toolbar a name 
     MyToolbar = "Fix Language" 

     On Error Resume Next    
     ''# so that it doesn't stop on the next line if the toolbar's already there 

     ''# Create the toolbar; PowerPoint will error if it already exists 
     Set oToolbar = CommandBars.Add(Name:=MyToolbar, _ 
         Position:=msoBarFloating, Temporary:=True) 
     If Err.Number <> 0 Then   
           ''# The toolbar's already there, so we have nothing to do 
           Exit Sub 
     End If 

     On Error GoTo ErrorHandler 

     ''# Now add a button to the new toolbar 
     Set oButton = oToolbar.Controls.Add(Type:=msoControlButton) 

     ''# And set some of the button's properties 
     With oButton 
          .DescriptionText = "Fix Language for Spell Check"    
           ''# Tooltip text when mouse if placed over button 
          .Caption = "Click to Run Script"     
          ''# Text if Text in Icon is chosen 
          .OnAction = "Button1"   
           ''# Runs the Sub Button1() code when clicked 
          .Style = msoButtonIcon     
           ''# Button displays as icon, not text or both 
          .FaceId = 59        

     End With 

     ''# Repeat the above for as many more buttons as you need to add 
     ''# Be sure to change the .OnAction property at least for each new button 

     ''# You can set the toolbar position and visibility here if you like 
     ''# By default, it'll be visible when created 
     oToolbar.Top = 150 
     oToolbar.Left = 150 
     oToolbar.Visible = True 

 NormalExit: 
     Exit Sub   ''# so it doesn't go on to run the errorhandler code 

 ErrorHandler: 
      ''# Just in case there is an error 
      MsgBox Err.Number & vbCrLf & Err.Description 
      Resume NormalExit: 
 End Sub 

 Sub Button1() 
 ''#         This is the code to replace the LanguageID throughout the ppt 
  Option Explicit    
  Public Sub ChangeSpellCheckingLanguage()    
  Dim j As Integer, k As Integer, scount As Integer, fcount As Integer  
  scount = ActivePresentation.Slides.Count  
  For j = 1 To scount  
  fcount = ActivePresentation.Slides(j).Shapes.Count  
  For k = 1 To fcount  
  If ActivePresentation.Slides(j).Shapes(k).HasTextFrame Then  
  ActivePresentation.Slides(j).Shapes(k) _  
  .TextFrame.TextRange.LanguageID = msoLanguageIDEnglishUS  
  End If  
  Next k  
  Next j  
  End Sub 

  End Sub

Answer 1

Это может быть невероятно поздний ответ, но я только что решил эту проблему, используя VBScript (который может быть запущен за пределами powerpoint). Написанный сценарий изменит язык каждого файла PowerPoint в данном каталоге (и подкаталогах) на английский. Вот сценарий:

Option Explicit

'microsoft office constants
Const msoTrue = -1
Const msoFalse = 0
Const msoLanguageIDEnglishUS = 1033
Const msoGroup = 6

'starting folder (current folder)
Const START_FOLDER = ".\"
'valid powerpoint file extensions
Dim FILE_EXTENSIONS : FILE_EXTENSIONS = Array("pptx", "pptm", "ppt", "potx", "potm", "pot")
'desired language for all Text
Dim DESIRED_LANGUAGE : DESIRED_LANGUAGE = msoLanguageIDEnglishUS

'VBScript file system objects for starting folder
Dim objFSO : Set objFSO = CreateObject("Scripting.FileSystemObject")
Dim objStartingFolder : Set objStartingFolder = objFSO.GetFolder(START_FOLDER)

IterateContainingItems objStartingFolder

'recursive subroutine to iterate each file in specified folder and all subfolders
Sub IterateContainingItems(objCurrentFolder)
    Dim colFiles : Set colFiles = objCurrentFolder.Files
    Dim objCurrentFile
    For Each objCurrentFile in colFiles
        ReportInfo(objCurrentFile)
    Next
    Dim colFolders : Set colFolders = objCurrentFolder.SubFolders
    Dim objNextFolder
    For Each objNextFolder in colFolders
        IterateContainingItems objNextFolder
    Next
End Sub

'subroutine executed for every file iterated by IterateContainingItems subroutine
Sub ReportInfo(objCurrentFile)
    Dim strPathToFile
    strPathToFile = objFSO.GetAbsolutePathName(objCurrentFile.Path)

    If isPowerpointFile(strPathToFile) Then
        Dim objPowerpointApp, objPresentations, objPresentation, objSlides, intSlideCount

        set objPowerpointApp = CreateObject("Powerpoint.Application")
        set objPresentations = objPowerpointApp.Presentations
        Set objPresentation = objPresentations.Open(strPathToFile, msoFalse, msoFalse, msoFalse)
        Set objSlides = objPresentation.Slides
        intSlideCount = objSlides.Count

        ResetLanguage objPresentation

        objPresentation.Save
        objPresentation.Close
        objPowerpointApp.Quit
    End If
End Sub

'check if given filepath specifies a powerpoint file as described by the "constant" extension array
Function isPowerpointFile(strFilePath)
    Dim strExtension, found, i
    strExtension = objFSO.GetExtensionName(strFilePath)
    found = false
    for i = 0 to ubound(FILE_EXTENSIONS)
        if FILE_EXTENSIONS(i) = strExtension then    
            found = true
            exit for
        end if
    next
    isPowerpointFile = found
End Function

'finds every shape in the entire document and attempts to reset its LanguageID
Sub ResetLanguage(objCurrentPresentation)
    Dim objShape

    'change shapes from presentation-wide masters
    If objCurrentPresentation.HasHandoutMaster Then
        For Each objShape in objCurrentPresentation.HandoutMaster.Shapes
            ChangeLanguage objShape
        Next
    End If
    If objCurrentPresentation.HasNotesMaster Then
        For Each objShape in objCurrentPresentation.NotesMaster.Shapes
            ChangeLanguage objShape
        Next
    End If
    If objCurrentPresentation.HasTitleMaster = msoTrue Then
        For Each objShape in objCurrentPresentation.TitleMaster.Shapes
            ChangeLanguage objShape
        Next
    End If
    'change shapes from each design's master
    Dim tempDesign
    For Each tempDesign in objCurrentPresentation.Designs
        For Each objShape in tempDesign.SlideMaster.Shapes
            ChangeLanguage objShape
        Next
    Next
    'change shapes from each slide
    Dim tempSlide
    For Each tempSlide in objCurrentPresentation.Slides
        For Each objShape in tempSlide.Shapes
            ChangeLanguage objShape
        Next
        If tempSlide.hasNotesPage Then
            For Each objShape in tempSlide.NotesPage.Shapes
                ChangeLanguage objShape
            Next
        End If
    Next
End Sub

'if the given shape contains a text element, it checks and corrects the LanguageID
'if the given shape is a group, it iterates through each element in the group
Sub ChangeLanguage(objShape)
    If objShape.Type = msoGroup Then
        Dim objShapeGroup : Set objShapeGroup = objShape.GroupItems
        Dim objShapeChild
        For Each objShapeChild in objShapeGroup
            ChangeLanguage objShapeChild
        Next
    Else
        If objShape.HasTextFrame Then
            Dim intOrigLanguage : intOrigLanguage = objShape.TextFrame.TextRange.LanguageID
            If Not intOrigLanguage = DESIRED_LANGUAGE Then
                If objShape.TextFrame.TextRange.Length = 0 Then
                    objShape.TextFrame.TextRange.Text = "[PLACEHOLDER_TEXT_TO_DELETE]"
                End If
                objShape.TextFrame.TextRange.LanguageID = DESIRED_LANGUAGE
                If objShape.TextFrame.TextRange.Text = "[PLACEHOLDER_TEXT_TO_DELETE]" Then
                    objShape.TextFrame.TextRange.Text = ""
                End If
            End If
        End If
    End If
End Sub

Чтобы запустить его, просто скопируйте и вставьте код в текстовый редактор и сохраните его как «script_name.vbs» в каталоге с вашими файлами powerpoint. Запустите его, дважды щелкнув скрипт и ожидая.

Answer 2

Ответ вполне очевиден, если он еще не ясен.

Как видите, sub Button1() инкапсулирует другой саб. Таким образом, советую убрать вызов ChangeSpellingCheckingLanguage и последний End sub, тогда ваш код будет работать.

Answer 3

Чтобы загрузить макрос при каждом открытии PowerPoint, вам нужно создать PowerPoint AddIn.Microsoft предоставила пошаговое руководство для Office XP .Для Office 2007 и новее AFAIK сделает следующие шаги:

• Сохранение файла в формате * .ppam в предложенном каталоге (%APPDATA%\Microsoft\AddIns)
• Откройте настройкинажмите кнопку Office в верхнем левом углу и выберите «Параметры PowerPoint»), выберите страницу «Надстройки», выберите «Надстройки PowerPoint» в раскрывающемся меню «Управление» и нажмите кнопку «Перейти».Откроется диалоговое окно.Выбор «Добавить новый» вызывает диалог выбора файлов.Вы должны иметь возможность выбрать файл там.

Вы также можете использовать Редактор пользовательского интерфейса Office для создания лент.

Однако я уже создалтакой надстройки Language Fixer для текущих версий PowerPoint, и я выложил ее для бесплатной загрузки для личного использования: PowerPoint Language Fixer от Jan Schejbal