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

问题

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

回答1:

I used the following code to test my theory progressively. It turned out correct.

Private Sub TestAX()

    Dim Rng As Range

    With ActiveDocument.Tables(1).Range
'        Debug.Print .Start, .End
'        Debug.Print .InlineShapes.Count
'        Debug.Print .InlineShapes(1).OLEFormat.Object.Name
        Set Rng = .InlineShapes(1).Range
    End With

    With Rng
'        Debug.Print .Start, .End
'        Debug.Print .Cells.Count
        Debug.Print .Cells(1).ColumnIndex, .Cells(1).RowIndex
    End With
End Sub

I started with only one, the first, Debug.Print in the procedure. When it worked, I disabled that line and tried the next, until I had the result I wanted in the end. The next step would be to create a loop which loops through all the InlineShapes in the table using a loop as described earlier this morning.

回答2:

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:

You cannot iterate through all cells of specific column as soon as that colum contains cell what are merged with cells from another column.
Any cell's content ends with a dot (chr 7) plus line break (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

来源：https://stackoverflow.com/questions/42934194/word-vba-get-position-of-an-activex-control-within-a-table

标签

word-vba