Move image without copy/paste - vba

Right now I have a Word macro that moves an image in front of specific text by copying and pasting it to that location. This works pretty well, but it is costly. If I have 1,000s of images in my word doc it could take 30 minutes to run the macro.
There has to be a better way right?
Can I move the image anchor without copy/pasting the entire image?
My end goal is to take text + an image that is aligned in a table (text left, image right), break it out of the table, but maintain that left/right nature.
Specifically, I am looking for images in tables (row 1 column 2) and want to move them to the beginning of the text in that same table (1st column, 1st row). Here is a snippet:
For Each shape In innerTable.Cell(1, 2).Range.InlineShapes
If shape.Type = wdInlineShapePicture Then
shape.Select
Selection.Cut
innerTable.Range.Paragraphs(1).Range.Characters(1).Paste
'Do it only for the 1st image found:
Exit For
End If
Next
Note, I am leaving out some safety checks for simplicity sake (this assumes I already have found a table of valid size, etc.

It is only possible to move a Shape if the target is on the same page. In that case, a Shape can be moved by changing its Top and Left properties. Unfortunately (extremely), there is no way to move an image by changing the anchor point. So the only way to move an image to another page (or story) is using copy/paste.
If an InlineShape is to be moved, just assign InlineShape.Range.FormattedText to the target Range. Or, extend a range with text to also include the InlineShape. As far as Word is concerned, an InlineShape is a character.
To achieve the stated end goal
take text + an image that is aligned in a table (text left, image
right), break it out of the table, but maintain that left/right nature
use a table with an additional column, on the right. Put the image in it as an InlineShape. Then the entire row can be handled, for example as follows.
This creates a new row in the desired position, copies the Range.FormattedText of the row to be moved to the new row. Removes the additional row this creates and also deletes the original row.
Sub MoveRow()
Dim tbl As Word.Table
Dim rwToMove As Word.Row
Dim rwTarget As Word.Row
Dim rwBeforeTarget As Word.Row
Dim posNewRow As Long
posNewRow = 1
Set rwToMove = Selection.Rows(1)
Set tbl = rwToMove.Range.Tables(1)
Set rwBeforeTarget = tbl.Rows(posNewRow)
Set rwTarget = tbl.Range.Rows.Add(rwBeforeTarget) '(posNewRow)
rwTarget.Range.FormattedText = rwToMove.Range.FormattedText
tbl.Rows(posNewRow + 1).Delete
rwToMove.Delete
End Sub

Related

Read OpenXML Table using OpenXML SDK with vertical merged cells

I'm writing a program that uses the OpenXML SDK to read OpenXML or Microsoft .docx files, and I've encountered a problem with tables. Because I know a user can create a lot of things, and Word loads, edits, and saves them, I know this is possible. Using Word 2010, I created a table with the following configuration:
This is designed to test horizontal merge, which can be accessed via the GridSpan property, and also vertical merge.
The problem I'm having is that the program can determine whether a cell has a vertical merge--but it cannot tell when that vertical merge ends. There is no RowSpan property for Wordprocessing.TableCell items that reliably lets me answer my question.
Dim objCell as Wordprocessing.TableCell
' Only operates when table cells have a vertical merge property...
If Not IsNothing(objSetup.VerticalMerge) Then
' Only operates if the vertical merge property exists...
If Not IsNothing(objSetup.VerticalMerge.Val) Then
' Sets the starting column number...
intColumn = 1
' Prepares to get the current row...
Dim trRow As Wordprocessing.TableRow
' Obtains the current row...
trRow = objCell.Parent
' Loops through table cells in the current row...
For Each tcCell As Wordprocessing.TableCell In trRow
' Counts the column...
intColumn = intColumn + 1
' Responds if the cell is identified...
If tcCell.OuterXml = objWord.OuterXml Then
' TEST: Notifies the user...
MsgBox("Matching cell found in column " & intColumn & vbCrLf & vbCrLf & objWord.OuterXml)
End If
Next
' TEST: Notifies the user...
MsgBox("Switching to Next Cell")
End If
End If
This program will consistently mistake any table cell with matching height as the current cell, even though the program is part of a loop that reads individual cells from the table, one at a time.
In the upper left corner of this example, where there are three cells with identical row heights, checking one cell will return three cells as "matches." Yes, they span two rows each, but no, the fact that there are three of them means they can't all be the same cell.
Is there any way to identify a specific cell (whether empty or not) in a specific column and a specific row while looping through a table using the OpenXML SDK?

Autofit to content then to window issues

I am trying to write a script to autofit tables first to content, then to window n Word 2010, as long as they are at least a certain width.
When I manually autofit to content then to window, the tables look nice and evenly spaced, however if I ONLY autofit to window they tend to have really wide first columns and squished up other columns.
code:
Sub AutoFitTables()
If ActiveDocument.Tables.Count > 0 Then
Dim objTable As Object
Application.Browser.Target = wdBrowseTable
For Each objTable In ActiveDocument.Tables
' Check the table width
If objTable.Columns.Width > 11520 Then
objTable.AutoFitBehavior (wdAutoFitContent)
' Again only fit tables above a certain width
If objTable.Columns.Width > 11520 Then
objTable.AutoFitBehavior (wdAutoFitWindow)
End If
End If
Next
End If
End Sub
issue:
The result is the same as when I manually ONLY auto fit to window. It's like it ignores the autofit to contents first
Is there something that I'm missing here? Or does anyone have suggestion of how to achieve the same effect as manually fitting to content, then to window?
edit:
It also seems to be ignoring the width constraint. I believe the table with is returned in Twips, so there should be only 11907 along the short edge and 16840 along the long edge, but not matter how large I set the cutoff (eg objTable.Columns.Width > 20000) it still autofits all tables. So if anyone knows why that is happening that would be helpful too

How to scroll to column in SpreadsheetGear WorkBookView control?

I have to proofread about 30-35 spreadsheets every week.
I need to look at column W and the columns to the right of column W. When I initially display the spreadsheet I see columns A-P. I manually scroll over to column W and begin proofreading the data.
I click on a next button which steps to the next file. My code loads the next spreadsheet:
WorkbookView1.ActiveWorkSheet = Workbook_Obj.ActiveWorksheet.
WorkbookView1.Update()
Sometimes the horizontal scroll position remains the same and I can see column W and some of the columns to the right of column W.
But sometimes the horizontal scroll position changes to the left of column W and I can't see column W anymore.
I'd to do something like this:
' 23 = Column W
Col_Obj = WorkbookView1.Cells(0, 23)
' Or - find column by header text in row = 0.
Col_Obj - WorkbookView1.FindByText("Name")
Col_Obj.HorizontalScroll = Col_Obj.Location
Thanks, Ed
You can set IWorksheetWindowInfo.ScrollColumn (note this property uses a zero-based index, i.e., where Column A is index 0, B is 1, and so on), which will set the leftmost column displayed in the window. Note there is a ScrollRow property as well if you need to set the row scroll position.
When a WorkbookView is involved, such as in your case, a number of additional factors can come into play as far as whether setting properties such as ScrollColumn will actually take effect on the WorkbookView (this has to do with the fact that you can attach the same worksheet to multiple WorkbookView controls and each WorkbookView can keep its own copy of these "window info" properties). Also, there are some behavioral differences in the way SpreadsheetGear 2012 and 2017 work in this regard. The below code should work in most cases and hopefully yours as well, though it may not in certain circumstances...for instance, if you are using SpreadsheetGear 2017 and attaching this worksheet to multiple WorkbookViews which I'm guessing you're not; but if so, I can update this answer to better accommodate your particular situation.
' Make local variable to the desired worksheet
Dim activeWorksheet = Workbook_Obj.ActiveWorksheet
' Reference cell to select and scroll to
Dim cellW1 = activeWorksheet.Cells("W1")
' Select the cell (this call alone can sometimes also automatically
' trigger the cell to be scrolled to as well, though it may not depending
' on the circumstances; and it may not make this cell the leftmost in the
' window...
cellW1.Select()
' ...to avoid any problems like mentioned above, explicitly set ScrollColumn
' to the selected cell. Set ScrollRow as well if desired.
activeWorksheet.WindowInfo.ScrollColumn = cellW1.Column
' Attach workbook *AFTER* doing the above. For a variety of reasons I
' won't go into, attaching the worksheet before setting the above "window
' info" options may not have any effect.
WorkbookView1.ActiveWorksheet = Workbook_Obj.ActiveWorksheet

Excel VBA Changing text inside shapes based off a range of cells

I have made a large diagram of made by shapes with numbers stored inside as text and need to change the "old" numbers to a "new" range of numbers. On each of the 20 sheets there are circles, Rectangles, Left Arrows and Right Arrows. The old range of numbers are stored on a separate spreadsheet in the Column "A" and need to be changed to the numbers listed in Column "B" (as in A1 to B1).
What would a VBA method to change the old text inside the Shapes to the new correct text based off of a new range of numbers? Is it possible to write a script that changes the values in the entire WorkBook?
My incorrect way of thinking is to:
1. Search inside the diagram to find the various shapes.
2. Get the text inside each shape.
3. Compare the text with the spreadsheet with the old numbers.
4. Insert the new number.
5. Move onto the next shape.
Put a value in A1 and say we already have a Shape:
Running this:
Sub LinkCellToShape()
Dim sh As Shape
Set sh = ActiveSheet.Shapes(1)
sh.DrawingObject.Formula = "=A1"
End Sub
will link the text in the shape to the value in the cell. You could also use:
sh.OLEFormat.Object.formula = "=A1"

Excel VBA how to select all cells in a dynamic range were the colour index is not 0

I have a SAP Report embedded in a worksheet, it is refreshed via a macro using variables defined in another worksheet. That all works fine, but i am having trouble selecting the data the report generates.
The headings of the report are in and always will fall in this range ("A17:K17"), but the results rows will vary making the total range I want to capture anywhere from ("A17:K18") to (A17:K1000").
The solutions I've already tried didn't work i think because there is almost no consistency in the result data, it's a mixture of text and numbers with empty cells all over the place, in both the rows and columns. Including the occasional completely empty row. This means the methods I have tried before reach a point where it thinks it's reached the end of the populated rows - but it hasn't.
The only factor that remains the same throughout the report is that the cells in the range I want to capture are all filled with a color as default and anything outside the range is unfilled.
To me the simplest solution would be to use VBA to select all the cells beneath and including the headers on ("A17:K17") where the color index is not 0 (blank?) regardless of their contents as I don't mind capturing empty cells. Except I don't know how to do this.
At this point I'd just like to select this range I haven't decided if I'm going to copy it into a new workbook or into an email yet, but that I can do. I've just hit a dead end selecting it.
Quite unsure exactly what it is you require but here's a solution. It's worth noting that both the ColorIndex and Color properties are not necessarily zero with no fill, so if you just change blankCell to a cell with the fill which you define to be blank you'll be good to go.
Sub test()
Set blankCell = Range("A1") ' change this to a cell that you define to be blank
blankIndex = blankCell.Interior.Color
Set cellsDesired = Range("A17:K17")
For Each cell In Range("A17:K1000")
If cell.Interior.Color <> blankIndex Then
Set cellsDesired = Application.Union(cellsDesired, Range(cell.Address))
End If
Next cell
cellsDesired.Select
End Sub