So I am getting this error Object Reference not set to an instance of an object. for some reason when I run it image = nothing which is causing rng = code to get this error.
Dim image As Excel.Shape
' This sets a reference to the image/end indactor.
image = oSheet.Shapes(oSheet.Shapes.Count)
' This sets up the range we are going to want to cut/copy over.
rng = oSheet.Range("A1", oSheet.Cells(image.TopLeftCell.Row + 3, 8))
You should always check for potential errors - especially when dealing with things like Excel!
Dim image As Excel.Shape
' This sets a reference to the image/end indactor.
image = oSheet.Shapes(oSheet.Shapes.Count)
If image IsNot Nothing Then
' This sets up the range we are going to want to cut/copy over.
rng = oSheet.Range("A1", oSheet.Cells(image.TopLeftCell.Row + 3, 8))
Else
Throw New Exception("There are no shapes on the sheet 'oSheet'.")
End If
That of course assumes oSheet is not Nothing as well. I hope that helps you on your way.
Related
I've written some code that formats text. The code doesn't work if user has put the cursor in a shape that is part of a group of shapes, the solution for which is to ungroup the shapes.
I want to regroup the shapes after executing the formatting code.
I am able to store the underlying shapes as objects, as well as their names. But, the normal approach to grouping (using shape names) doesn't work, because there can be multiple instances of those shape names on a given slide. E.g. this doesn't work as there could be multiple instances of "textbox" on the slide:
Set TempShapeGroup = TempSlide.Shapes.Range(Array("textbox", "header", "separator")).Group
https://learn.microsoft.com/en-us/office/vba/api/powerpoint.shaperange.group
But, I have the shape objects stored in an array, the crux of which is this (the object 'TempShape' is the group of shapes):
Dim ShapesArray() As Shape
ReDim ShapesArray(1 To TempShape.GroupItems.Count)
For i = 1 To TempShape.GroupItems.Count
Set ShapesArray(i) = TempShape.GroupItems.Item(i)
Next i
So, what I want to do is recreate the group of shapes, using the array of shape objects, so something to the effect of the below would be ideal:
Set MyShapesGroup= ShapesArray.Group
But any way to group shapes using Shape objects would be fine.
TIA
Here's some starter code that you can modify into a function that'll return a reference to the paragraph that contains the current selection cursor. It doesn't really need all the debug.print stuff, of course, but that might help to illustrate the object hierarchy:
Sub WhereIsTheCursor()
Dim oRng As TextRange
Dim oParentRange As TextRange
Dim x As Long
Dim lSelStart As Long
Dim lSelLen As Long
With ActiveWindow.Selection.TextRange
' find the selection start relative to first character in shape
lSelStart = .Start
' lSelLen = .Length
Debug.Print TypeName(.Parent)
Debug.Print TypeName(.Parent.Parent)
Debug.Print TypeName(.Parent.Parent.Parent)
Debug.Print .Paragraphs.Count
Set oRng = .Characters(.Start, .Length)
Debug.Print oRng.Text
' Reference the overall shape's textrange
Set oParentRange = .Parent.Parent.TextFrame.TextRange
' For each paragraph in the range ...
For x = 1 To oParentRange.Paragraphs.Count
' is the start of the selection > the start of the paragraph?
If lSelStart > oParentRange.Paragraphs(x).Start Then
' is the start < the start + length of the paragraph?
If lSelStart < oParentRange.Paragraphs(x).Start _
+ oParentRange.Paragraphs(x).Length Then
' bingo!
MsgBox "The cursor is in paragraph " & CStr(x)
End If
End If
Next
End With
End Sub
Not sure I'm completely understanding the problem, but this may help:
If the user has selected text within a shape, it doesn't really matter whether the shape is part of a group or not. You may need to test the .Selection.Type and handle things differently depending on whether the .Type is text or shaperange. Example:
Sub FormatCurrentText()
If ActiveWindow.Selection.Type = ppSelectionText Then
With ActiveWindow.Selection.TextRange
.Font.Name = "Algerian"
End With
End If
End Sub
I wrote a macro that hides everything in several geometrical sets and the objects and geometrical sets in these first sets except one specific branch. I use this for saving a defined object of a huge and complicated specification tree as a STP file. (See attached below.)
(Small complication in this “Hide_and_Save” macro: adding bodies to my hide-selection works well but for my show-selection it didn’t work the same way. Why would this happen?)
I also wrote a macro that does iterative adjustments. For the iterations I use a Do While Loop and some parameters and measurements. To update these values, I have to update the part/object in every cycle. But there are some construction elements that issue errors until the loop is successfully completed. Therefore I deactivate all the geometrical sets that I don’t need for the iterations (inclusively all children) and later I reactivate them manually.
My goal is to improve automation, so I tried to use my “Hide_and_Save” macro for deactivation and reactivation. This didn’t work. When I record the process, each object is listed in a separate line and deactivated. Since there are more than 350 elements, I would like to avoid this.
How do I deactivate all subelements in a geometrical set (preferably with children) without addressing each element individually?
Attribute VB_Name = "Hide_and_Save"
'_______________________________________________________________________________________
'Title: Hide_and_Save
'Language: catvba
'_______________________________________________________________________________________
Sub CATMain()
'---------------------------------------------------------------------------------------
'Select active Part/Document
Dim myDocument As Document
Set myDocument = CATIA.ActiveDocument
Dim myPart As part
Set myPart = CATIA.ActiveDocument.part
'--------------------------------------------------------------
' Enter file path
Dim filepath As String
filepath = InputBox("Please select memory location", "Input filepath", "...")
If filepath = "" Then 'cancle, abort or empty input
MsgBox "No valid input / cancle !"
Exit Sub
End If
'--------------------------------------------------------------
' Hide/show Objects of Part/Products and save as STEP
' Update Model
CATIA.ActiveDocument.part.Update
' Deklaration of Selections and Properties
Dim selectionShow, selectionHide As Selection
Set selectionShow = myDocument.Selection
Set selectionHide = myDocument.Selection
Dim visPropertySetShow, visPropertySetHide As VisPropertySet
Set visPropertySetShow = selectionShow.VisProperties
Set visPropertySetHide = selectionHide.VisProperties
' Definition of the collection of geometric sets - HybridBodies
Dim hybridBodiesInPart, hybridBodiesInProcess As HybridBodies
Dim hybridBodiesInRS, hybridBodiesInHuelle As HybridBodies
' Definition of individual geometric sets - HybridBody
Dim hybridBodyInPart, hybridBodyProcess, hybridBodyInProcess As HybridBody
Dim hybridBodyRS, hybridBodyInRS As HybridBody
Dim hybridBodyHuelle, hybridBodyInHuelle As HybridBody
' Definition of the collection of 3D-objects - HybridShapes
Dim hybridShapesInHuelle As HybridShapes
' Definition of individual 3D-objects - HybridShape
Dim hybridShapeInHuelle, hybridShapeForm As HybridShape
' Hide objects
Set hybridBodiesInPart = myPart.HybridBodies
For Each hybridBodyInPart In hybridBodiesInPart
selectionHide.Add hybridBodyInPart
Next
Set hybridBodyProcess = hybridBodiesInPart.Item("Process")
Set hybridBodiesInProcess = hybridBodyProcess.HybridBodies
For Each hybridBodyInProcess In hybridBodiesInProcess
selectionHide.Add hybridBodyInProcess
Next
Set hybridBodyHuelle = hybridBodiesInProcess.Item("Huelle")
Set hybridBodiesInHuelle = hybridBodyHuelle.HybridBodies
For Each hybridBodyInHuelle In hybridBodiesInHuelle
selectionHide.Add hybridBodyInHuelle
Next
Set hybridShapesInHuelle = hybridBodyHuelle.HybridShapes
For Each hybridShapeInHuelle In hybridShapesInHuelle
selectionHide.Add hybridShapeInHuelle
Next
Set hybridShapeForm = hybridShapesInHuelle.Item("Form")
visPropertySetHide.SetShow 1 'hide
selectionHide.Clear
' Show objects
selectionShow.Add hybridBodyProcess
selectionShow.Add hybridBodyHuelle
selectionShow.Add hybridShapeForm
visPropertySetShow.SetShow 0 'show
selectionShow.Clear
' Data export as STP
stepAnswer = MsgBox("Should the displayed elements be saved as STEP?", 3 + 0, "Export: Form")
If stepAnswer = 6 Then
myDocument.ExportData filepath & "Form" & ".stp", "stp"
ElseIf stepAnswer = 3 Or stepAnswer = 2 Then 'cancle or abort
MsgBox "cancle !"
Exit Sub
End If
'---------------------------------------------------------------------------------------
MsgBox "Finished !" & vbCrLf & s
End Sub
(Usually I work with Generative Shape Design and use VBA for Macros.)
Each feature has an "Activity" parameter aggregated to it.
Dim oShape as HybridShape
For Each oShape In oGS.HybridShapes
Dim oActivity as Parameter
Set oActivity = oPart.Parameters.SubList(oShape,False).Item("Activity")
Call oActivity.ValuateFromString("False")
Next
Let me add that screwing with Activity of features is not a best practice. I NEVER do this myself. If you have access KBE (Specifically Knowledge Advisor Workbench) you can probably do what you want with Rules/Actions/Reactions, less coding and have a more robust model in the end.
Using the below code i get a 424 error "Object Required" on the .AddPicure line as indicated. I'm unsure as to why as pic is dimensioned as object, and the .addpicture comand looks fully referenced to me.
Apologies for the length of code, i thought it best to leave in all variables.
I'm using Excel 13 from MS Visio 16, and late binding is necessary.
**Edit: Sorry, it is infact an add text box line thats giving me the problem, I've updated the code below...
Sub testexcel()
Dim pic As Object
Dim rng As Object
Dim tWidth As Long, tHeight As Long
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set xlWb = xlApp.workbooks.Open("C:\Users\tom\Desktop\Book1.xlsx")
Set xlWs = xlWb.sheets("Sheet1")
xlApp.ScreenUpdating = False
Set rng = xlWs.Range("B18")
Set rng2 = xlWs.Range("A1", rng.Offset(-1, -1))
picture1 = "C:\Users\tom\Desktop\PX001.bmp"
pHeight = 145
pWidth = 200
tHeight = 10
tWidth = 200
posX = 10
posY = 10
'On Error GoTo ErrMsg
With xlWs.Range("A1", rng.Offset(-1, -1))
'*******Problem on next line*******
Set txtBx = xlWs.Shapes.AddTextbox(msoTextOrientationHorizontal,
txtPosX, txtPosY, tWidth, tHeight).TextFrame.Characters.Text = "FooBar"
End With
'Some other code here...
End Sub
try splitting it up
Set txtBx = xlWs.Shapes.AddTextbox(msoTextOrientationHorizontal, txtPosX, txtPosY, tWidth, tHeight)
txtBx.TextFrame.Characters.Text = "FooBar"
I think this is what's happening:
xlWs.Shapes.AddTextbox(msoTextOrientationHorizontal, txtPosX, txtPosY, tWidth, tHeight).TextFrame.Characters.Text = "FooBar"
This retunrs false because the second = is interpreted as a comparison. Then you are basically doing Set txtBx = False which causes the error.
It could also be that vba tries to assign the Text property which is a string to txtBx.
edit: I would also suggest using Option Explicit. If VBA knows that txtBx is supposed to be a shape, it tells you it got a type mismatch. In this case you got lucky because the Set tells it to expect an object and thus threw an error. If you wanted to assign a string for example, you would have gotten the error at a later line (or no error at all) because you have False where you expect a string which makes debugging more complicated.
Someone else's code in the project, that I am trying to fix up.
listO.Range(i, j).FormulaR1C1 = FormulaMatrix(i, j)
where FormulaMatrix(i, j) is always a String value. Whatever random/test value, I try with, is being assigned successfully, except when it is a formula, eg.
=IF(LENGTH([#Units])>0;[#SalesAmount]-[#DiscountAmount]0)
If I remove the = sign in the beginning of the formula, it gets assigned correctly, but then it's useless, because it's not a formula.
#Units, #SalesAmount, #DiscountAmount are references/names of columns.
So, when assigning a formula, I get an exception HRESULT: 0x800A03EC. I looked up in this answer in order to get explanation and followed some of the instructions there. I determined that my problem is the following: the problem happens due to a function entered in a cell and it is trying to update another cell.
Checked out also this post. I tried quite different (like putting just the formulas without = and then run over again and put the equal signs), but same problem.
I am clueless of how to approach this.
.formulalocalworks! (While .formula, .value and .formular1c1 don't.)
I've just started working with VB.NET and came into a very similar issue. This was my simplified data at first (Table1 in Sheet1):
Then after applying the code below I had this:
The whole code for the form:
Imports Excel = Microsoft.Office.Interop.Excel
Public Class Form1
'~~> Define your Excel Objects
Dim xlApp As New Excel.Application
Dim xlWorkBook As Excel.Workbook
Dim xlWorkSheet As Excel.Worksheet
Dim strAddress As String = "C:\Temp\SampleNew.xlsx"
Dim list1 As Object
Private Sub btnOpen_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles btnOpen.Click
'~~> Add a New Workbook (IGNORING THE TWO DOT RULE)
xlWorkBook = xlApp.Workbooks.Open(strAddress)
'~~> Display Excel
xlApp.Visible = True
'~~> Set the relevant sheet that we want to work with
xlWorkSheet = xlWorkBook.Sheets("Sheet1")
With xlWorkSheet
'~~> Change the range into a tabular format
list1 = .ListObjects("Table1")
End With
list1.range(2, 4).formulalocal = "=IF(LEN([#Month])>5;[#Income]-[#MoneySpent];0)"
'~~> Save the file
xlApp.DisplayAlerts = False
xlWorkBook.SaveAs(Filename:=strAddress, FileFormat:=51)
xlApp.DisplayAlerts = True
'~~> Close the File
xlWorkBook.Close()
'~~> Quit the Excel Application
xlApp.Quit()
'~~> Clean Up
releaseObject(xlApp)
releaseObject(xlWorkBook)
End Sub
'~~> Release the objects
Private Sub releaseObject(ByVal obj As Object)
Try
System.Runtime.InteropServices.Marshal.ReleaseComObject(obj)
obj = Nothing
Catch ex As Exception
obj = Nothing
Finally
GC.Collect()
End Try
End Sub
End Class
#Siddharth Rout helped a lot to build this code, as he owns this awesome site: http://www.siddharthrout.com/
The error might be coming from your current data, respectively, the layout of the sheet. I would suggest you to check what is inside the listO.Range(i, j).FormulaR1C1 before you assign the formula.
I have had a case where the range has already got wrong data inside, and then strangely, I don't know why, I cannot assign the new formula.
If that is the case - try clearing the value of the range and then assigning the formula:
listO.Range(i, j).FormulaR1C1 = ""
listO.Range(i, j).FormulaR1C1 = FormulaMatrix(i, j)
The problem might be with your formula. Try this-
=IF(LEN([#Units])>0,[#SalesAmount]-[#DiscountAmount],0)
If this doesn't work, I would try using the .formula method instead of .formulaR1C1.. Is there any reason in particular you are using R1C1 references?
I have an Excel worksheet (called Fee Planner - Standard Input) with a table on it (called StandardInput) and a button which calls a VBA Sub to add a new row to the bottom of the table:
Public Sub AddStandardInputRow()
Dim standardInputTable As ListObject
Dim newRow As ListRow
Set standardInputTable = ThisWorkbook.Worksheets("Fee Planner - Standard Input").ListObjects("StandardInput")
Set newRow = standardInputTable.ListRows.Add
Set standardInputTable = Nothing
End Sub
I seem to get random results from running this code, sometimes it works perfectly for a few rows and then starts to error, sometimes it errors from the first time the button is clicked. The errors thrown are
followed by
I only get the first error once, but after that I consistently get the 1004 error. SOmetimes I get the first error immediately after restarting Excel.
I'm guessing there's some underlying cause, but I can't see what it is.
What happens if you use:
Sub M_snb()
With Sheet1.ListObjects(1).Range
sheet1.Cells(.Rows(.Rows.Count + 1).Row, .Columns(1).Column) = " "
End With
End sub
So it seems the problems lie with the lines
Dim newRow As ListRow
...
Set newRow = standardInputTable.ListRows.Add
It appears there's a reference leak in that code on the newRow object.
I tried including a
Set newRow = Nothing
line on the penultimate line of the method which was better but still not great, I've now removed all reference to the newRow object completely so the method just calls standardInputTable.ListRows.Add, this seems to be much more reliable:
Public Sub AddStandardInputRow()
Dim standardInputTable As ListObject
Set standardInputTable = ThisWorkbook.Worksheets("Fee Planner - Standard Input").ListObjects("StandardInput")
standardInputTable.ListRows.Add
Set standardInputTable = Nothing
End Sub