I have a macro that will append a page to the current document from a pre-formatted template. This page inserts a picture based off user selection, which they have the standard excel supported images(i.e. .jpg, .png, .bmp) as well as PDF's(taken off an AutoCAD program that can only save as PDF/DWG/DXF file types. The problem I'm having is that I cannot rotate landscape print formatted images the way that I can with the regular images. I know that the problem is likely that not all OLEobjects can be rotated and the shaperange option probably does not allow for rotation. That being said, is it possible to do this within VBA?
I have tried to use the OLEobject shaperange option, as well as inserting the PDF as a picture(which is not supported by MS-Office as far as I know). I have also tried to select the OLEobject as a shape to no avail.
Set rng = crrntWorkbook.Sheets(1).Range("B" & tempRow)
'Allows for the insertion of PDF files into the workbook
Set oleobj = ActiveSheet.OLEObjects.Add(Filename:=txtFileName, link:=False, DisplayAsIcon:=False)
With oleobj
'Inserts the picture into the correct cell
oleobj.Top = rng.Top
oleobj.Left = rng.Left
'If the image is wider than it's height, image will be scaled down by it's width, otherwise it's height
If oleobj.Width > oleobj.Height Then
oleobj.IncrementRotation = 90
oleobj.Width = 545
oleobj.Left = (570 - oleobj.Width) / 2
oleobj.Top = oleobj.Top + 2
'Centers the image
Else
oleobj.Height = 625
oleobj.Left = (550 - oleobj.Width) / 2
oleobj.Top = oleobj.Top + 2
End If
End With
The expected result is that the image will be rotated upon insertion, but I will get either a "runtime error '438' Object doesn't support this property or method" or a "runtime error -2147024809 the shape is locked and cannot be rotated if I use the shaperange approach"
Related
This one is driving me nuts.
I'm trying to place an image in a spreadsheet.
The following is a created snippet to show what I'm trying to do, but fails at .AddPicture with a TypeMismatch error. What is curious is that despite the failure it still places the image in the correct position, correctly sized.
`
Private Sub cmdLayImage_Click(y as Integer, x as Integer)
Dim lsF As String
Dim loShps As Excel.Shapes
Dim loS As Shape
Dim c As Integer
lsFilename = "Moorland.jpg"
goXsTT.Cells(Y, x).Select
'Fails with Err 13 at this line
Set loShps = goXsTT.Shapes.AddPicture(gsTerrainImagePath & lsFilename, _
msoFalse, msoTrue, ActiveCell.Left, ActiveCell.Top, -1, -1)
c = loShps.Count
loS = loShps(c)
loS.Name = c
MsgBox "Shape Number/Name = " & loS.Name
End Sub
`
I've tried various settings for Link To File and Save To Document, I've used absolute figures for height, width, top and bottom I also tried Csng() each to be sure; nothing works - yet the image is laid, but loShps never gets set.
Any help greatly appreciated.
Thanks Dave
I'm attempting to use the Shapes object as placing an image directly into a selected cell using:
Set loPicInCell = goXsTT.Pictures.Insert(gsTerrainImagePath & lsFilename)
whilst it works, is limiting in the methods available (in particular .OnAction)
I´m trying to create a code in vba excel to detect what´s inside the work flow objects - 3D as the ones shown in the following picture:
The pictures are always the same. I have been able to find and select the sentence inside the cell. But I need it to search for all the work flow objects in different visio.
This is where I got to:
Dim DiagramServices As Integer
DiagramServices = ActiveDocument.DiagramServicesEnabled
ActiveDocument.DiagramServicesEnabled = visServiceVersion140 + visServiceVersion150
Dim vsoCharacters1 As Visio.Characters
Set vsoCharacters1 = Application.ActiveWindow.Page.Shapes.ItemFromID(228).Characters
Debug.Print vsoCharacters1
I need the code to first find all the work flow objects in different pages in visio and then obtain the sentence within (vsoCharacters1)
Please try this simple code
Sub ttt()
Dim doc As Document ' Variable for Document
Dim pg As Page ' Variable for Page
Dim shp As Shape ' Variable for Shape
Dim txt As String ' Variable for Shape's text
For Each doc In Documents ' Iterate all documents in Visio application session
For Each pg In doc.Pages ' Iterate all pages in 'doc'
For Each shp In pg.Shapes ' Iterate all docunents in 'pg'
txt = shp.Text ' Define 'txt' variable
Select Case txt ' Criterion
Case "ololo", "trololo" ' Found text
ActiveWindow.Page = pg ' Activate page with criterion
ActiveWindow.Select shp, visSelect ' Select shape with criterion
MsgBox "Page: " & pg.Name & ", ShapeID: " & shp.ID, , "A shape was found, the text of which matches the criterion: " & txt
End Select
ActiveWindow.DeselectAll ' Unselect a shape
Next shp
Next pg
Next doc
MsgBox "TheEnd!!!"
End Sub
Note:
This code started in MS Visio, code without recursion, dont find shapes into groups !
May I propose a more systematic approach?
Drawing explorer
Make sure you're in developer mode.
Switch the drawing explorer on.
Identify the shape to explore
Expand its tree to see its sub-shapes
If you're lucky a pro has made this shape and named the subshapes eg Label, Frame, what ever. This will simplify the access to this shape.
in VBA:
shp being your group shape object
access the sub-shape via: set subshp = shp.Shapes(name_of_subshape)
This works also for the sub-shapes of the sub-shape.
Otherwise - the sub-shapes are named sheet.234 - you need to find another identification method.
Open the shapesheet of the sub-shape (right-mouse-click)
Inspect it and try to figure out in how far it differs from the other sub-shapes. That can be a text, user or prop field, a geometry section ... etc.
in VBA you would then loop over all the sub-shapes and check for this property.
eg:
for each subshape in shp.Shapes:
if subshape.CellExists("soAndSo",0) then
if subshape.Cells("soAndso").ResultStr("") = "thisAndThat" then
'you found it, do your stuff.
By the way, you don't need to access the characters object of a shape to get its text. It is simply "shp.Text". The characters object is more complexe and lets you do funny stuff with the text.
I have an Excel spreadsheet displayed within an old VB6 application using OLE but recently the table is displayed very small for some reason. I did not change the code recently as far as I know and the problem seems to be only on users' computers.
Is there any way of forcing the size of display?
Changing the scale in the template file makes no difference.
Changing the sizemode makes no difference:
olePumpDetails.CreateLink g_strRangePumpDocumentation & strTemplate
If Not m_bDetailsExcelError Then
Set oBook = olePumpDetails.object
Set osheet = oBook.Sheets(1)
SetDetailExcelValues oBook, osheet
olePumpDetails.Refresh
End If
Elsewhere in the project on resize of form:
If olePumpDetails.Visible = True Then
olePumpDetails.Visible = False
olePumpDetails.Move 100, 400, Me.Width - 300, Me.Height - 1000
lblPumpDetailsError.Move (Me.ScaleWidth / 2) - (lblPumpDetailsError.Width / 2), lblPumpDetailsError.Top, lblPumpDetailsError.Left, lblPumpDetailsError.Top
olePumpDetails.Visible = True
End If
I expected the spreadsheet to be displayed normal size.
The Window object has a read / write Zoom property.
From the Microsoft Office Dev Center:
Returns or sets a Variant value that represents the display size of the window, as a percentage (100 equals normal size, 200 equals double size, and so on).
If Not m_bDetailsExcelError Then
Set oBook = olePumpDetails.object
Set osheet = oBook.Sheets(1)
SetDetailExcelValues oBook, osheet
oBook.Windows(1).Zoom = 200 'set the default zoom
olePumpDetails.Refresh
End If
After a Paste special linking of a range of cells from Excel to Word (2013) the field looks like this:
{ LINK Excel.SheetMacroEnabled.12 D:\\20181228\\SC.xlsm Sheet1!R10C1:R10C20" \a \p }
If you click on the object with the right button, select "Format object" and then click on "?", the Format AutoShape reference article opens.
However, ActiveDocument.Shapes.SelectAll does not detect this object.
This code also does not work, although the error message says that this component is available for pictures and OLE objects:
With ActiveDocument.Shapes(1).PictureFormat
.ColorType = msoPictureGrayScale
.CropBottom = 18
End With
What is this object?
I cannot find it in Object model (Word).
How to access it through VBA?
I want to programmatically resize a group of such objects to 90% of the original.
Upd. #Cindy Meister suggested where to dig, thanks.
I wrote the code, it seems to work fine:
Sub ResizeImages()
Dim img As Long
With ActiveDocument
For img = 1 To .InlineShapes.Count
With .InlineShapes(img)
.ScaleHeight = 90
.ScaleWidth = 90
End With
Next img
End With
End Sub
A Link field must be an InlineShape - it can't be a Shape, not if you can display the field using Alt+F9. Since Shape objects have text wrap formatting any field codes associated with them (usually none) aren't accessible.
Therefore, any object that's displayed via a Link field should be available via the InlineShape object model.
For example, the following code loops the fields in the document and, if they're link fields with an Excel source and contain an InlineShape, the InlineShape's dimensions are scaled:
Dim fld as Word.Field
For Each fld In ActiveDocument.Fields
If fld.Type = wdFieldLink
If fld.Result.InlineShapes.Count > 1 And _
InStr(fld.OLEFormat.ClassType, "Excel") Then
Set ils = fld.Result.InlineShapes(1)
ils.ScaleWidth = 90
ils.ScaleHeight = 90
End If
End If
Next
I'm creating a series of tags in Illustrator, using VBA in excel (the excel worksheet has the information that populates the tags), and I cannot find a way to specify that the font which appears in Illustrator is italicized and a particular font.
Using:
.TextRange.CharacterAttributes.TextFont = appIll.TextFonts.Item("Arial")
lends the same result as using:
.TextRange.CharacterAttributes.TextFont = appIll.TextFonts.Item("Monotype Corsiva")
And needless to say, I also can't get italics. I'm very new to this, but would appreciate anyone letting me know how to specify the font and font-style. Thanks!
.TextRange.ParagraphAttributes.Justification = aiCenter
.TextRange.CharacterAttributes.size = dblTopLine1FontSize
.TextRange.CharacterAttributes.StrokeWeight = 0.35
.TextRange.CharacterAttributes.StrokeColor = clrStrokeColor
.TextRange.CharacterAttributes.FillColor = clrFontFillColor
SetItalics tfrmTopLine1
.CreateOutline
End With
have a look at the following to see if it helps:
Firstly, at the risk of stating the obvious, I first identified that the font I 'needed' to use was indeed accessible to my copy of Illustrator - as it happens, to use Monotype Corsiva in code it has to be "MonotypeCorsiva"! The lessons here are that the 'real' font name may be different from the Illustrator displayed font name and the 'real' font name also indicates the 'style'. I used the following code which simply listed the font and its 'style' to Excel's Immediate Window. Illustrator needs to be open for this example.
Sub IllFnts()
Dim IApp As New Illustrator.Application
Set IApp = GetObject(, "Illustrator.Application")
Dim fnt As Illustrator.TextFont
For Each fnt In IApp.TextFonts
Debug.Print fnt.Name & " - " & fnt.Style
Next
End Sub
I then added a Point Text Frame, added some text and changed the TextFont with the code below:
EDIT - UPDATE TO INCLUDE A MEANS OF APPLYING ITALIC
Sub TestChngeFnt()
Dim IApp As New Illustrator.Application
If IApp Is Nothing Then
Set IApp = CreateObject("Illustrator.Application")
Else
Set IApp = GetObject(, "Illustrator.Application")
End If
Dim fnt As Illustrator.TextFont
'A distinctive font for reference?
Set fnt = IApp.TextFonts("Algerian")
'Add a Document
Set docRef = IApp.Documents.Add()
'Add some Point Text
Set pointTextRef = docRef.TextFrames.Add()
pointTextRef.Contents = "Some Text in a Point TextFrame"
pointTextRef.Top = 700
pointTextRef.Left = 20
pointTextRef.Selected = True
pointTextRef.TextRange.CharacterAttributes.Size = 35
IApp.Redraw
'Set distinctive font
IApp.Documents(1).TextFrames(1).TextRange.CharacterAttributes.TextFont = IApp.TextFonts.Item(fnt.Name)
MsgBox "Have a look at the text font before changing to another."
'set a new font to 'regular'
Set fnt = IApp.TextFonts("BodoniMT")
IApp.Documents(1).TextFrames(1).TextRange.CharacterAttributes.TextFont = IApp.TextFonts.Item(fnt.Name)
MsgBox "New text font before changing to italics."
'set font to 'italics' within the same font family?
Set fnt = IApp.TextFonts("BodoniMT-Italic")
IApp.Documents(1).TextFrames(1).TextRange.CharacterAttributes.TextFont = IApp.TextFonts.Item(fnt.Name)
End Sub
This example includes a couple of message boxes to pause the code to observe the text changes.
Applying 'italic' in this example is really selecting a font from the same font family designed as italic? Not completely sure if this is the 'correct' approach with Illustrator or just a workaround,but it may take you forward a little.
You may also find this Adobe Illustrator CS5 Scripting Reference: vbScript useful although the Object Browser in Excel is also a good starting reference.