locked
VBA and Add-in Microsoft Word 2010 not working consistently without running show code RRS feed

  • Question

  • I have a for with a ,dot extension that calls the VBA below. It works consistently in Word 2003 and 2007, and works sometimes in 2010 but mostly not. If I open the Visual Basic editor on the Developer toolbar and run the following code - the toolbar displays. Obviously my users do now have access to this function. Is there a way I can call this sub routine CheckDocType() after the form loads in 2010 to make the toolbar appear? Any suggestions would be appreciated.


    Public Sub CheckDocType()

    Dim MsgText As String

    Dim MsgResp As Integer

    If CommandBars("Attachments").Controls.Count = 0 Then

    CommandBars("Attachments").Visible = False

    Else

    CommandBars("Attachments").Visible = True

    End If

    End Sub
    -----------------

    Const StartSectionCnt = 1
    Public Sub CheckDocType()
      Dim MsgText As String
      Dim MsgResp As Integer

      If CommandBars("Attachments").Controls.Count = 0 Then
        CommandBars("Attachments").Visible = False
      Else
          CommandBars("Attachments").Visible = True
      End If
      Doc = Application.ActiveWindow.Caption
      MsgText = "Applications Need To Be A Template Type." + Chr(13) + _
                "Please Refer To Section In The User Manual Labeled" + Chr(13) + _
                "Completing the Application Form For Further Information."
      If ActiveDocument.Type <> wdTypeTemplate Then
        MsgResp = MsgBox(MsgText, vbOKOnly)
        Application.OnTime When:=Now, Name:="CloseDocument"
      End If
    End Sub

    Public Sub CloseDocument()
      Application.ActiveDocument.Close (wdDoNotSaveChanges)
    End Sub

    Private Sub InsertAttachment()
    Dim MsgResp As Integer
    Dim I As Integer
    Dim MsgText As String
    Dim ContentStr As Template

    MsgText = "Attachments Already On Application." + Chr(13) + _
              "Do You Want To Replace?"

    On Error GoTo Error_Handler
    Set ContentStr = CustomizationContext
    CustomizationContext = ActiveDocument
    If ActiveDocument.Bookmarks.Exists("Attachments") = True Then
        MsgResp = MsgBox(MsgText, vbYesNo)
    End If

    If MsgResp <> vbNo Then
      ActiveDocument.Unprotect ("sampson")
      If MsgResp = vbYes Then
        Selection.GoTo what:=wdGoToBookmark, Name:="Attachments"
        ActiveDocument.Bookmarks("Attachments").Delete
        Selection.EndKey unit:=wdStory, Extend:=wdExtend
        Selection.MoveLeft unit:=wdCharacter, Count:=1, Extend:=wdExtend
        Selection.Delete
      End If
      Selection.EndKey unit:=wdStory
      ActiveDocument.Bookmarks.Add Name:="Attachments"
      Selection.InsertBreak (wdSectionBreakNextPage)
      dlg = Dialogs(wdDialogInsertFile).Show
      Call CreateAttachToolBar
    Error_Handler:
      If Err.Number <> 0 Then
        MsgBox (Err.Description)
      End If
      ActiveDocument.Protect Type:=wdAllowOnlyFormFields, NoReset:=True, Password:="sampson"
      CustomizationContext = ContentStr
      CommandBars("Attachments").Visible = True
    End If

    End Sub

    Private Sub CreateAttachToolBar()
    Dim FF_Num As Integer
    Dim FF_Num_Str As String
    Dim CurrentLevel As Integer
    Dim FoundFF As Boolean
    Dim BtnCnt As Integer
    Dim btnForm() As CommandBarControl
      On Error GoTo Error_Handler
    '  For I = 1 To ActiveDocument.CommandBars.Count
    '    If CommandBars(I).Name = "Attachments" Then
    '       CommandBars(I).Delete
    '   End If
    '  Next I
      FF_Num = 1
      KeyBindings.ClearAll
      Do While CommandBars("Attachments").Controls.Count > 0
        CommandBars("Attachments").Controls(1).Delete
      Loop
      CurrentLevel = 0
      BtnCnt = 0
      Do While FF_Num + StartSectionCnt <= ActiveDocument.Sections.Count
        FF_Num_Str = Trim(Str(FF_Num))
        Selection.GoTo what:=wdGoToSection, which:=wdGoToAbsolute, Count:=(FF_Num + StartSectionCnt)
        If ActiveDocument.FormFields("Level" + FF_Num_Str).Result > CurrentLevel Then
          If CurrentLevel = BtnCnt Then
            BtnCnt = BtnCnt + 1
            ReDim Preserve btnForm(BtnCnt)
          End If
          CurrentLevel = CurrentLevel + 1
        Else
          If ActiveDocument.FormFields("Level" + FF_Num_Str).Result < CurrentLevel Then
            CurrentLevel = CurrentLevel - 1
          End If
        End If
        If CurrentLevel = 1 Then
          Set btnForm(BtnCnt) = ActiveDocument.CommandBars("Attachments").Controls.Add(msoControlPopup, , , , False)
          btnForm(BtnCnt).Caption = "Attachments"
          Call PullInAttachments(FF_Num, btnForm(BtnCnt), CurrentLevel)
        Else
          If ActiveDocument.FormFields("Level" + FF_Num_Str).Result = CurrentLevel Then
             Set btnForm(CurrentLevel) = btnForm(CurrentLevel - 1).Controls.Add(msoControlPopup)
             btnForm(CurrentLevel).Caption = ActiveDocument.FormFields("Folder" + FF_Num_Str).Result
             Call PullInAttachments(FF_Num, btnForm(CurrentLevel), CurrentLevel)
          End If
        End If
      Loop
    Error_Handler:
      If Err.Number <> 0 Then
        MsgBox (Err.Description)
      End If
    End Sub

    Private Sub PullInAttachments(FF_Num As Integer, _
                                  btnForm As CommandBarControl, _
                                  CurrentLevel As Integer)
    Dim FF_Num_Str As String

      FF_Num_Str = Trim(Str(FF_Num))
      ActiveDocument.FormFields("Level" + FF_Num_Str).Delete
      ActiveDocument.FormFields("Folder" + FF_Num_Str).Delete
      Selection.Tables.Add Range:=Selection.Range, NumRows:=1, NumColumns:=1
      Set SortTable = ActiveDocument.Tables(ActiveDocument.Tables.Count)
      TabCnt = ActiveDocument.Tables.Count
      For I = 1 To ActiveDocument.Sections(FF_Num + StartSectionCnt).Range.Bookmarks.Count
        If I > 1 Then
          SortTable.Rows.Add
        End If
        SortTable.Cell(I, 1).Range.InsertAfter UCase(ActiveDocument.Sections(FF_Num + StartSectionCnt).Range.Bookmarks(I).Name)
      Next I
      If SortTable.Rows.Count > 1 Then
         SortTable.Sort ExcludeHeader:=False, FieldNumber:=1, SortFieldType:=wdSortFieldAlphanumeric, SortOrder:=wdSortOrderAscending
      End If
      For I = 1 To ActiveDocument.Sections(FF_Num + StartSectionCnt).Range.Bookmarks.Count
        Set cmbSubControl = btnForm.Controls.Add(msoControlButton, , , , False)
        Caption = Mid(SortTable.Cell(I, 1), 1, Len(SortTable.Cell(I, 1)) - 2)
        With cmbSubControl
          .Caption = Caption
          .OnAction = "GetAttachment"
          .Parameter = Caption
        End With
      Next I
      SortTable.Delete
      FF_Num = FF_Num + 1
    End Sub

    Private Sub GetAttachment()
      Dim Doc As String
      Dim Doc2 As String
      Dim WordDoc As Boolean
         
      On Error GoTo Error_Handler
      ActiveDocument.Unprotect ("sampson")
      Doc = Application.ActiveWindow.Document.Name
      ActiveDocument.Bookmarks.Add Name:="LeftOff"
      Selection.GoTo what:=wdGoToBookmark, Name:=CommandBars.ActionControl.Parameter
      Selection.InlineShapes(1).OLEFormat.Activate
      WordDoc = False
      If Application.ActiveWindow.Document.Name <> Doc Then
        Doc2 = Application.ActiveWindow.Document.Name
        WindowsIndex = 0
        Do While Application.ActiveWindow.Document.Name <> Doc
          WindowsIndex = WindowsIndex + 1
          Documents(WindowsIndex).Activate
        Loop
        WordDoc = True
      End If
      Selection.GoTo what:=wdGoToBookmark, Name:="LeftOff"
      ActiveDocument.Bookmarks("LeftOff").Delete
    Error_Handler:
      If Err.Number <> 0 Then
        MsgBox (Err.Description)
      End If
      ActiveDocument.Protect Type:=wdAllowOnlyFormFields, NoReset:=True, Password:="sampson"
      If WordDoc Then
        Documents(Doc2).Activate
      End If
    End Sub

     

     

     

     


    jim neal

    Sunday, September 16, 2012 12:36 AM

Answers

  • Without your documents it is all a bit hazy. There are several undeclared variables in your code, some wrongly declared variables and one or two other oddities. There is also very little in the way of error handling - some of which would appear to be significant.

    I have fixed some of the more glaring issues, and the code does produce a command bar in Word 2010 - though whether it is what was intended I cannot say.

    Option Explicit
    Const StartSectionCnt = 1
    Public Sub CheckDocType()
    Dim MsgText As String
    Dim MsgResp As Integer
    Dim Doc As String
    Dim cb As CommandBar
    Dim bFound As Boolean

    For Each cb In CommandBars
        If cb.Name = "Attachments" Then
            If cb.Controls.Count = 0 Then
                cb.Visible = False
            Else
                cb.Visible = True
            End If
            bFound = True
            Exit For
        End If
    Next cb

    If Not bFound Then MsgBox "The command bar does not exist", vbInformation
    Doc = Application.ActiveWindow.Caption
    MsgText = "Applications Need To Be A Template Type." + Chr(13) + _
              "Please Refer To Section In The User Manual Labeled" + Chr(13) + _
              "Completing the Application Form For Further Information."
    If ActiveDocument.Type <> wdTypeTemplate Then
        MsgResp = MsgBox(MsgText, vbOKOnly)
        Application.OnTime When:=Now, Name:="CloseDocument"
    End If
    End Sub

    Public Sub CloseDocument()
    Application.ActiveDocument.Close (wdDoNotSaveChanges)
    End Sub

    Private Sub InsertAttachment()
    Dim MsgResp As Integer
    Dim i As Integer
    Dim MsgText As String
    Dim ContentStr As Template

    MsgText = "Attachments Already On Application." + Chr(13) + _
              "Do You Want To Replace?"

    On Error GoTo Error_Handler
    Set ContentStr = CustomizationContext
    CustomizationContext = ActiveDocument

    If ActiveDocument.Bookmarks.Exists("Attachments") = True Then
        MsgResp = MsgBox(MsgText, vbYesNo)
    End If

    If MsgResp <> vbNo Then
        ActiveDocument.Unprotect ("sampson")
        If MsgResp = vbYes Then
            Selection.GoTo what:=wdGoToBookmark, Name:="Attachments"
            ActiveDocument.Bookmarks("Attachments").Delete
            Selection.EndKey unit:=wdStory, Extend:=wdExtend
            Selection.MoveLeft unit:=wdCharacter, Count:=1, Extend:=wdExtend
            Selection.Delete
        End If
        Selection.EndKey unit:=wdStory
        ActiveDocument.Bookmarks.Add Name:="Attachments"
        Selection.InsertBreak (wdSectionBreakNextPage)
        Dialogs(wdDialogInsertFile).Show
        Call CreateAttachToolBar
    Error_Handler:
        If Err.Number <> 0 Then
            MsgBox (Err.Description)
        End If
        ActiveDocument.Protect Type:=wdAllowOnlyFormFields, NoReset:=True, Password:="sampson"
        CustomizationContext = ContentStr
        CommandBars("Attachments").Visible = True
    End If
    End Sub

    Private Sub CreateAttachToolBar()
    Dim FF_Num As Integer
    Dim FF_Num_Str As String
    Dim CurrentLevel As Integer
    Dim FoundFF As Boolean
    Dim BtnCnt As Integer
    Dim btnForm() As CommandBarControl
    Dim cb As CommandBar
    Dim bFound As Boolean

    On Error GoTo Error_Handler
    FF_Num = 1
    KeyBindings.ClearAll


    For Each cb In CommandBars
        If cb.Name = "Attachments" Then
            If cb.Controls.Count = 0 Then
                cb.Visible = False
            Else
                cb.Visible = True
            End If
            bFound = True
            Exit For
        End If
    Next cb

    If bFound Then
        Do While CommandBars("Attachments").Controls.Count > 0
            CommandBars("Attachments").Controls(1).Delete
        Loop
    End If
    CurrentLevel = 0
    BtnCnt = 0
    Do While FF_Num + StartSectionCnt <= ActiveDocument.Sections.Count
        FF_Num_Str = Trim(str(FF_Num))
        Selection.GoTo what:=wdGoToSection, which:=wdGoToAbsolute, Count:=(FF_Num + StartSectionCnt)
        If ActiveDocument.FormFields("Level" + FF_Num_Str).Result > CurrentLevel Then
            If CurrentLevel = BtnCnt Then
                BtnCnt = BtnCnt + 1
                ReDim Preserve btnForm(BtnCnt)
            End If
            CurrentLevel = CurrentLevel + 1
        Else
            If ActiveDocument.FormFields("Level" + FF_Num_Str).Result < CurrentLevel Then
                CurrentLevel = CurrentLevel - 1
            End If
        End If
        If CurrentLevel = 1 Then
            Set btnForm(BtnCnt) = ActiveDocument.CommandBars("Attachments").Controls.Add(msoControlPopup, , , , False)
            btnForm(BtnCnt).Caption = "Attachments"
            Call PullInAttachments(FF_Num, btnForm(BtnCnt), CurrentLevel)
        Else
            If ActiveDocument.FormFields("Level" + FF_Num_Str).Result = CurrentLevel Then
                Set btnForm(CurrentLevel) = btnForm(CurrentLevel - 1).Controls.Add(msoControlPopup)
                btnForm(CurrentLevel).Caption = ActiveDocument.FormFields("Folder" + FF_Num_Str).Result
                Call PullInAttachments(FF_Num, btnForm(CurrentLevel), CurrentLevel)
            End If
        End If
    Loop
    Error_Handler:
    If Err.Number <> 0 Then
        MsgBox (Err.Description)
    End If
    End Sub

    Private Sub PullInAttachments(FF_Num As Integer, _
                                  btnForm As CommandBarControl, _
                                  CurrentLevel As Integer)
    Dim FF_Num_Str As Long
    Dim SortTable As Table
    Dim TabCnt As Long
    Dim i As Long
    Dim cmbSubControl As Control
    Dim strCaption As String
    Dim oCell As Range

    FF_Num_Str = Val(Trim(str(FF_Num)))
    ActiveDocument.FormFields("Level" + FF_Num_Str).Delete
    ActiveDocument.FormFields("Folder" + FF_Num_Str).Delete
    Selection.Tables.Add Range:=Selection.Range, NumRows:=1, NumColumns:=1
    Set SortTable = ActiveDocument.Tables(ActiveDocument.Tables.Count)
    TabCnt = ActiveDocument.Tables.Count
    For i = 1 To ActiveDocument.Sections(FF_Num + StartSectionCnt).Range.Bookmarks.Count
        If i > 1 Then
            SortTable.Rows.Add
        End If
        Set oCell = SortTable.Cell(i, 1).Range
        oCell.End = oCell.End - 1
        oCell.InsertAfter UCase(ActiveDocument.Sections(FF_Num + StartSectionCnt).Range.Bookmarks(i).Name)
    Next i
    If SortTable.Rows.Count > 1 Then
        SortTable.Sort ExcludeHeader:=False, FieldNumber:=1, SortFieldType:=wdSortFieldAlphanumeric, SortOrder:=wdSortOrderAscending
    End If
    For i = 1 To ActiveDocument.Sections(FF_Num + StartSectionCnt).Range.Bookmarks.Count
        Set cmbSubControl = btnForm.Controls.Add(msoControlButton, , , , False)
        Set oCell = SortTable.Cell(i, 1).Range
        oCell.End = oCell.End - 1
        strCaption = Mid(oCell.Text, 1, Len(oCell.Text) - 2)
        With cmbSubControl
            .Caption = strCaption
            .OnAction = "GetAttachment"
            .Parameter = strCaption
        End With
    Next i
    SortTable.Delete
    FF_Num = FF_Num + 1
    End Sub

    Private Sub GetAttachment()
    Dim Doc As String
    Dim Doc2 As String
    Dim WordDoc As Boolean
    Dim WindowsIndex As Long
    Dim bProtected As Boolean

    If Documents.Count = 0 Then Exit Sub
    On Error GoTo Error_Handler
    If ActiveDocument.ProtectionType <> wdNoProtection Then
        ActiveDocument.Unprotect ("sampson")
        bProtected = True
    End If
    Doc = Application.ActiveWindow.Document.Name
    ActiveDocument.Bookmarks.Add Name:="LeftOff"
    Selection.GoTo what:=wdGoToBookmark, Name:=CommandBars.ActionControl.Parameter
    Selection.InlineShapes(1).OLEFormat.Activate
    WordDoc = False
    If Application.ActiveWindow.Document.Name <> Doc Then
        Doc2 = Application.ActiveWindow.Document.Name
        WindowsIndex = 0
        Do While Application.ActiveWindow.Document.Name <> Doc
            WindowsIndex = WindowsIndex + 1
            Documents(WindowsIndex).Activate
        Loop
        WordDoc = True
    End If
    Selection.GoTo what:=wdGoToBookmark, Name:="LeftOff"
    ActiveDocument.Bookmarks("LeftOff").Delete
    Error_Handler:
    If Err.Number <> 0 Then
        MsgBox (Err.Description)
    End If
    If bProtected Then
        ActiveDocument.Protect Type:=wdAllowOnlyFormFields, NoReset:=True, Password:="sampson"
    End If
    If WordDoc Then
        Documents(Doc2).Activate
    End If
    End Sub


    Graham Mayor - Word MVP
    www.gmayor.com

    • Marked as answer by JamesLNeal Sunday, October 28, 2012 1:06 PM
    Sunday, September 16, 2012 6:35 AM