none
word vba: get position of an ActiveX control within a table RRS feed

  • Question

  • I want to get the position (row & column) of a ActiveX button, placed in a table. So far I know only how to get a hand on the button
    Selection.Fields.Item(1).OLEFormat.Object
    all ActiveX Controls are listed in
    Me.Content.InlineShapes
    It seems that I can access the parent table via
    selection.tables.item(1)
    but I don't how to determine the position of the button within that table, e.g. c5r8


    • Edited by StefanM83 Tuesday, March 21, 2017 8:09 PM
    Tuesday, March 21, 2017 8:07 PM

All replies

  • Hello Stefan,

    You could use the code below to get the position of current button.

    Private Sub CommandButton1_Click()
    Dim cel As Cell                  
    Set cel = Selection.Cells.Item(1)
    MsgBox "RowIndex:" & cel.RowIndex & vbCrLf & _
           "ColumnIndex" & cel.ColumnIndex
    End Sub
    

    Regards,

    Celeste


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    Wednesday, March 22, 2017 2:52 AM
    Moderator
  • thank you for your input and excuse my late response.
    With the help of your suggestion I was able to write some code what purpose is to:

    • number each row what contains an reference to an document (let's call it item). It even distinguish between plain text and text field
    • create a button in the last cell of each row what contains an item and add code for each button
    • tried to clear the intermediate window but it ether clears my code window or does nothing, depending on the chosen approach. So it's still buggy

    The code got quite complex since the code for deleting already present buttons didn't work well. Eventually I came to the conclusion that is due to a bug in Word.

    The code for renumbering the rows is mostly self explaining. I came across two major hurdles:

    1.  You cannot iterate through all cells of specific column as soon as that colum contains cell what are merged with cells from another column.
    2. Any cell's content begins with a dot (chr 7) and contains a space (char 13), see here.    
      Before you do any numeric check of the cells content you have to remove those chars. I wrote a little function for that purpose (*toRemoveFromString*).
       

    My proof in order to figure out, if a row has to be numbered is simple. It is  merely checked if the first cell in a row is numeric, that means that you have to prepare the table before running the code otherwise it won't work.
    In order to keep the processing time low, the check is carried out only when the current cell of the loop is in the last column. From there on I reference to the first cell etc.   
     In order to distinguish if a cell contains a text form field, I proof it via the property `...Range.FormFields.Count`. That implies that you only use either plain text or a text form field per single cell
    The code will work only if you select the table what is to be edited otherwise I had to search through the entire document to find the right table but I haven't found a easy way to do that yet.


    Private Sub CB_ReNumberDocTable_Click()
        Dim toRemoveArray() As Variant
        Dim ceTableCell As Cell, ceFirstCellinRow As Cell
        Dim tabThisTable As Table
        Dim i As Integer, iCurrentCol As Integer, iCurrentRow As Integer, iNoCol As Integer
        Dim stCellText As String
    
        toRemoveArray = Array(Chr(13), Chr(7))
        Set tabThisTable = Selection.Tables(1)
        iNoCol = tabThisTable.Range.Columns.Count
        i = 1
    
        For Each ceTableCell In tabThisTable.Range.Cells   '.Columns(iNoCol) -> not working since mixed celles
            iCurrentCol = ceTableCell.Range.Cells.Item(1).ColumnIndex
            iCurrentRow = ceTableCell.Range.Cells.Item(1).RowIndex
            If iCurrentCol = iNoCol Then
                Set ceFirstCellinRow = tabThisTable.Cell(iCurrentRow, 1)
                stCellText = toRemoveFromString(ceFirstCellinRow.Range, toRemoveArray)
                If IsNumeric(stCellText) Then
                    If ceFirstCellinRow.Range.FormFields.Count = 1 Then
                        ceFirstCellinRow.Range.FormFields.Item(1).Result = Format(i, "00")
                    Else
                        ceFirstCellinRow.Range.Text = Format(i, "00")
                    End If
                i = i + 1
                End If
            End If
        Next
    Set tabThisTable = Nothing
    Set ceFirstCellinRow = Nothing
    
    End Sub

      

    That following part of my code got quite complex since it never deleted all present buttons completely. For the sake of traceability I want to give any button a unique and self-explaining name instead of referring to the random names given by Word.   
    Each button's name shell be terminated with row's index number. That implies that there is only one button per row and thus you better delete all buttons in all rows except certain buttons with independent unique names, which e.g. trigger this macro.  
    The deleting runs quite well the first time I running it but from the second time onwards it skips one button but deletes one of those non-related  buttons although the filter, what decides what button is to be deleted and what not is very simple and clear.

     Private Sub CB_CreateSAPButtonsStep1_Click()
            Dim isShape As InlineShape
            Dim isShape1 As InlineShape
            Dim isShape2 As InlineShape
            Dim isShape3 As InlineShape
            Dim tabThisTable As Table
            Dim i As Integer
            Dim stShapeName  As String
            Dim stSenderName As String
    
                Set tabThisTable = Selection.Tables(1)
                stSenderName = Selection.Fields.Item(1).OLEFormat.Object.Name
                If tabThisTable.Range.InlineShapes.Count > 0 Then
                For i = tabThisTable.Range.InlineShapes.Count To 1 Step -1
                    Set isShape = tabThisTable.Range.InlineShapes.Item(i)
                    Set isShape1 = tabThisTable.Range.InlineShapes.Item(1)
                    Set isShape2 = tabThisTable.Range.InlineShapes.Item(2)
                    Set isShape3 = tabThisTable.Range.InlineShapes.Item(3)
                    stShapeName = isShape.OLEFormat.Object.Name
                    If Not isShape.OLEFormat.Object.Name = isShape1.OLEFormat.Object.Name Then        'stShapeName = "CB_ReNumberDocTable" Then    'InStr(1, isShape.OLEFormat.Object.Name, stSAPButtonName, 1) > 0 Then
                        If Not isShape.OLEFormat.Object.Name = isShape2.OLEFormat.Object.Name Then         'stShapeName = "CB_CreateSAPButtonsStep1" Then
                            If Not isShape.OLEFormat.Object.Name = isShape3.OLEFormat.Object.Name Then         'stShapeName = "CB_CreateSAPButtonsStep2" Then
                                Debug.Print "delete :" & isShape.OLEFormat.Object.Name
                                tabThisTable.Range.InlineShapes.Item(i).Delete
                            End If
                        End If
                    End If
                Next
            End If
    
            Set tabThisTable = Nothing
            Set isShape = Nothing
        End Sub
    This code proofs if the row has to be numbered, as the renumber code and insert a button in the last cell of the row.    
          

    Afterwards the buttons gets properly renamed and formatted. Due to the bug explained before is fails from the second run onwards. So I delete I have to delete remaining button manually before running it again. Luckily I don't run it that often.

     Private Sub CB_CreateSAPButtonsStep2_Click()
                Dim toRemoveArray() As Variant
                Dim VBProj As VBIDE.VBProject
                Dim VBComp As VBIDE.VBComponent, moModul As VBIDE.VBComponent
                Dim tabThisTable As Table
                Dim i As Integer, iCurrentCol As Integer, iCurrentRow As Integer, iNoCol As Integer
                Dim stSAPButtonModuleName As String, stSAPButtonName As String, stCellText As String, stcode As String,
                Dim isShape As InlineShape
                Dim ceTableCell As Cell, ceFirstCellinRow As Cell                
                iNoCol = Selection.Tables(1).Range.Columns.Count
    
                stSAPButtonModuleName = "mo_SAPLinkButtons"
                stSAPButtonName = "CB_SAPLink"
                toRemoveArray = Array(Chr(13), Chr(7))
    
                Set tabThisTable = Selection.Tables(1)
                Set VBProj = ActiveDocument.VBProject
    
                Application.ScreenUpdating = False
    
                For Each moModul In VBProj.VBComponents 'http://www.cpearson.com/excel/vbe.aspx
                    If moModul.Name = stSAPButtonModuleName Then
                         Set VBComp = VBProj.VBComponents(stSAPButtonModuleName)
                        VBProj.VBComponents.Remove VBComp
                    End If
                Next
                Set VBComp = VBProj.VBComponents.Add(vbext_ct_StdModule)
                VBComp.Name = stSAPButtonModuleName
    
                'Exit Sub
                'Debug.Print Now
        'https://social.msdn.microsoft.com/Forums/office/en-US/da87e63f-676b-4505-adeb-564257a56cfe/vba-to-clear-the-immediate-window?forum=exceldev
                'Application.SendKeys "^g ^a {DEL}"
    
                'Call ClearImmediateWindow
                i = 1
                For Each ceTableCell In tabThisTable.Range.Cells   '.Columns(iNoCol) -> not working since mixed celles
                    iCurrentCol = ceTableCell.Range.Cells.Item(1).ColumnIndex
                    iCurrentRow = ceTableCell.Range.Cells.Item(1).RowIndex
                    If iCurrentCol = iNoCol Then
                        Set ceFirstCellinRow = tabThisTable.Cell(iCurrentRow, 1)
                        stCellText = toRemoveFromString(ceFirstCellinRow.Range, toRemoveArray)
                        If IsNumeric(stCellText) Then
                            'Debug.Print "create shape"
                            'http://ccm.net/faq/1105-adding-a-vba-commandbutton-with-its-respective-the-code
                            'https://support.microsoft.com/de-ch/help/246299/how-to-add-a-button-to-a-word-document-and-assign-its-click-event-at-run-time
                            Set isShape = ceTableCell.Range.InlineShapes.AddOLEControl(ClassType:="Forms.CommandButton.1") ', Left:=0, Top:=0, Width:=15.75, Height:=11.25)
                            isShape.OLEFormat.Object.Caption = ""
                            isShape.OLEFormat.Object.Height = 11.25
                            isShape.OLEFormat.Object.Width = 15.75
                            isShape.OLEFormat.Object.BackColor = RGB(255, 255, 255)  '&HFFFFFF
                            isShape.OLEFormat.Object.ForeColor = RGB(255, 255, 255) '&HFFFFFF
                            isShape.OLEFormat.Object.BackStyle = fmBackStyleTransparent
                            'isShape.OLEFormat.Object.Name = stSAPButtonName & Format(iCurrentRow, "00")
    
                            stcode = "Private Sub " & isShape.OLEFormat.Object.Name & "_Click()" & vbCrLf & _
                                    "   call openSAPLink" & vbCrLf & _
                                    "End Sub"
                            Set isShape = Nothing
    
                            VBProj.VBComponents(stSAPButtonModuleName).CodeModule.AddFromString stcode
    
                            i = i + 1
                        End If
                    End If
    
    
            '        Debug.Print ceTableCell.Range
            '        Debug.Print ceTableCell.Range.Cells.Item(1).ColumnIndex
            '        Debug.Print ceTableCell.Range.Cells.Item(1).RowIndex
                Next
    
                Application.ScreenUpdating = True
    
                Set tabThisTable = Nothing
                Set VBProj = Nothing
                Set VBComp = Nothing
                Set moModul = Nothing
                Set isShape = Nothing
                Set ceFirstCellinRow = Nothing
    
                For i = 1 To iNoCol
                    'Debug.Print Selection.Tables(1).Range.Columns(iNoCol - 1)
                Next
            End Sub

    This the little helper what removes Chr(13) & Chr(7)

        Private Function toRemoveFromString(stString, toRemove())
        Dim chrItem As Variant
    
            For Each chrItem In toRemove()
                stString = Replace(stString, chrItem, "")
            Next
            toRemoveFromString = stString
        End Function

      

    The still buggy code for clearing the immediate window

     Private Sub ClearImmediateWindow()
        'https://www.mrexcel.com/forum/excel-questions/300075-clear-visual-basic-applications-editor-immediate-window.html
        'https://www.experts-exchange.com/questions/28426212/How-to-clear-the-Immediate-Window-in-VBA.html
        'https://access-programmers.co.uk/forums/showthread.php?t=253466
        On Error Resume Next
        Dim winImm As VBIDE.Window
        Dim winActive As VBIDE.Window
          ' set the Window object variable to the Current Window for later reactivation
          Set winActive = VBE.ActiveWindow
    
          ' set the Window object variable to the Immediate Window
          Set winImm = VBE.Windows("Immediate")
          ' now clear it as you would do "manually"
          winImm.SetFocus
          Application.VBE.Windows.Item("Immediate").SetFocus
          SendKeys "^({Home})", True
          SendKeys "^(+({End}))", True
          SendKeys "{Del}", True
          Debug.Print Now
          Set winImm = Nothing
    
          'set focus back on window that was active before
          'winActive.SetFocus
        End Sub
    




                                                                                                                                                                                                                                                                 
    Friday, April 7, 2017 2:40 PM
  • You could probably have saved yourself a lot of time and effort if you'd described what you were trying to do.

    You also have some significant misconceptions. For example, neither of these claims is correct:

    1.  You cannot iterate through all cells of specific column as soon as that colum contains cell what are merged with cells from another column.
    2. Any cell's content begins with a dot (chr 7) and contains a space (char 13),

    Iterating through the merged cells in a column is fairly straightforward and cells do not start Chr(7) and Chr(13) is not a space; a space is Chr(32) and cells end with a Chr(7) & Chr(13) pair.

    You also say:

    • The code will work only if you select the table what is to be edited otherwise I had to search through the entire document to find the right table but I haven't found a easy way to do that yet.

    but specifying the table to work on is quite simple - simply specify the table #, via ActiveDocument.Tables(#), where # is the table's position in the document.

    The following re-write of your CB_ReNumberDocTable_Click sub shows how you can tell the code to process all cells in column 1 of table 4 in the document, even if that column has vertically-merged cells.

    Sub CB_ReNumberDocTable_Click()
    Application.ScreenUpdating = False
    Dim r As Long
    With ActiveDocument.Tables(4)
      For r = 1 To .Rows.Count
        On Error Resume Next
        With .Cell(r, 1).Range
          If .FormFields.Count = 1 Then
            .FormFields(1).Result = Format(r, "00")
          Else
            .Text = Format(r, "00")
          End If
        End With
      Next
    End With
    Application.ScreenUpdating = True
    End Sub

    The above code will be far more efficient than your own code because:

    1. It avoids screen updates while running;
    2. processes only column 1; and
    3. doesn't unnecessarily concern itself with the Chr(7) & Chr(13) pair.

    Cheers
    Paul Edstein
    [MS MVP - Word]

    Monday, April 10, 2017 1:23 AM
  • Hi Paul,
    your code may works with vertical merged cells but not if there are horizontal merged cells.

    If there are horizontal merged cells you will run into error  "Run-time error '5992': Cannot access indivual coloumns in this collection because the table has mixed cell widths"

    Using Format(r"00") is not avoiding the ●  problem, at least in word 2010.

    br

    Stefan



    Tuesday, April 18, 2017 11:06 AM
  • Hi Paul,
    your code may works with vertical merged cells but not if there are horizontal merged cells.



    In my testing, the macro as posted works in Word 2010 regardless of whether the table might have:
    •no;
    • vertically;
    • horizontally; or
    • a mix of horizontally and vertically,
    merged cells. It will even work with a table that has mixed cell widths in the first column.


    Cheers
    Paul Edstein
    [MS MVP - Word]

    Tuesday, April 18, 2017 11:59 AM