I have been using 32 bit MS Excel and this Macro worked fine. Now I have moved to 64 bit Excel 2016 and macro is not working. What is the problem with it? Is there a solution to get it work with both 32 bit and 64 bit versions?
Sub Rectangle_Clicked()
Button = Application.Caller
Rectangle_Toggle (Button)
End Sub
Sub Rectangle_Toggle(Button As Variant)
With Application.ActiveSheet.Shapes(Button)
'Transparency of the shape 1 = transparent, 0 = solid
.Fill.Transparency = 1
'Hides the cell's value
Range(.TopLeftCell.Address).Font.Color = Range(.TopLeftCell.Address).Interior.Color
If .TextFrame.Characters.Text = Chr$(252) Then
.TextFrame.Characters.Text = ""
.Fill.ForeColor.RGB = RGB(255, 255, 255)
Range(.TopLeftCell.Address).Value = False
Else
.TextFrame.Characters.Text = Chr$(252)
.Fill.ForeColor.RGB = RGB(46, 208, 80) '(50, 195, 50) <-- change your color here
Range(.TopLeftCell.Address).Value = True
End If
End With
End Sub
I am getting an error "Can't find project in library". And VB highlights word button in Button = Application.Caller
Related
With VBA I often create 2 complementary line charts in an excel Spreadsheet. Typically, the 2 charts have the same number of SeriesCollections, and every ch1.SeriesCollection(i) (SC(I)) is related related to ch2.SeriesCollection(i), but not the same chart. It is desirable for the plot colors to be the same for each i in both chart. It is also desirable to be able to selectively remove and restore using VBA selective plots (e.g., all i values except i = 2) using isfiltered as in VBA code below.
All the code below works as desired, except the last statement: "ch1.SeriesCollection(2).IsFiltered = False". The previous statement "= True" removes (from view) SeriesCollection(2) from the chart, and the "= False" should restore it for view. But it does not. And I can't find a solution. Guidance to solution will be greatly appreciated. Thank you.
Sub Charts1()
Dim sh1, chr1, chr2 As Variant
On Error Resume Next
Set sh1 = ActiveSheet
sh1.Cells.Clear
sh1.ChartObjects.Delete
sh1.Range("B1:D1") = [{"A","B","C"}]
sh1.Range("A2:A3") = [{"1";"2"}]
sh1.Range("A2:A3").AutoFill Destination:=Range("A2:A12"), Type:=xlFillDefault
sh1.Range("B2:D2").FormulaR1C1 = "1"
sh1.Range("B3:B12").FormulaR1C1 = "=R[-1]C*1.02"
sh1.Range("C3:C12").FormulaR1C1 = "=R[-1]C*1.04"
sh1.Range("D3:D12").FormulaR1C1 = "=R[-1]C*1.06"
sh1.Range("A1:A12,B1:D1").HorizontalAlignment = xlCenter
sh1.Range("B2:D12").NumberFormat = "#,##0.000"
Set ch1 = sh1.Shapes.AddChart2(227, xlLine).Chart
ch1.SetSourceData Source:=Range("Data!$A$1:$D$12")
ch1.Parent.Left = 50
ch1.Parent.Top = 200
Set ch2 = sh1.Shapes.AddChart2(227, xlLine).Chart
ch2.SetSourceData Source:=Range("Data!$A$1:$D$12")
ch2.Parent.Left = 450
ch2.Parent.Top = 200
ch1.SeriesCollection(1).Format.Line.ForeColor.RGB = RGB(255, 0, 0)
ch1.SeriesCollection(2).Format.Line.ForeColor.RGB = RGB(0, 255, 0)
ch1.SeriesCollection(3).Format.Line.ForeColor.RGB = RGB(0, 0, 255)
ch2.SeriesCollection(1).Format.Line.ForeColor.RGB = RGB(255, 255, 0)
ch2.SeriesCollection(2).Format.Line.ForeColor.RGB = RGB(0, 255, 255)
ch2.SeriesCollection(3).Format.Line.ForeColor.RGB = RGB(255, 0, 255)
c1s1color = ch1.SeriesCollection(1).Format.Line.ForeColor.RGB
For i = 1 To ch2.SeriesCollection.Count
ch2.SeriesCollection(1).Format.Line.ForeColor.RGB = ch1.SeriesCollection(1).Format.Line.ForeColor.RGB
ch2.SeriesCollection(2).Format.Line.ForeColor.RGB = ch1.SeriesCollection(2).Format.Line.ForeColor.RGB
ch2.SeriesCollection(3).Format.Line.ForeColor.RGB = ch1.SeriesCollection(3).Format.Line.ForeColor.RGB
Next i
ch1.SeriesCollection(2).IsFiltered = True
ch1.SeriesCollection(2).IsFiltered = False
End sub
I have managed with input the textbox to the formula, as per the following query, which I raised a while ago...
VBA Excel how to write Excel formula in the textbox
and everything is fine, but I have got problems with input the proper font features into this textbox.
Basically I have two separate sets of code, which I would love to combine into the one
Sub Duct1()
Set myDocument = ActiveSheet
With myDocument.Shapes.AddTextbox(msoTextOrientationHorizontal, 300, 140, 180, 30)
.name = "Duct1"
With .TextFrame
.HorizontalAlignment = xlLeft
With .Characters
.Text = "1W-20mm/90' upturn"
.Font.ColorIndex = 3
.Font.Size = 16
.Font.Bold = True
End With
End With
.Rotation = 25
.Fill.Visible = False
.Line.Visible = False
End With
End Sub
Sub Duct1Desc()
ActiveSheet.Shapes("Duct1").OLEFormat.Object.Formula = "=AB1"
End Sub
For the second code I tried also:
Sub Duct1Desc()
ActiveSheet.Shapes("Duct1").OLEFormat.Object.Formula = "=AB1"
With ActiveSheet.Shapes("Duct1")
.Font.ColorIndex = 3
.Font.Size = 16
.Font.Bold = True
End With
End Sub
But in this issue I have got an error, that VBA doesn't support this property or method.
Can anyone help me to bind these 2 codes together?
Thanks
This works for me:
Dim s As Shape
Set s = ActiveSheet.Shapes("myBox")
s.DrawingObject.Formula = "=B2"
OK I thought the problem was the linking, not the formatting: this works for me.
Sub Duct1Desc()
Dim s
Set s = ActiveSheet.Shapes("Duct1")
s.OLEFormat.Object.Formula = "=A1"
With s.DrawingObject
.Font.ColorIndex = 3
.Font.Size = 20
.Font.Bold = True
End With
End Sub
I am running an Excel macro in a C# program.
I have a chart and I'd like to change its properties.
Here's the code I've tried:
ActiveSheet.ChartObjects("myChart").Activate
ActiveChart.Axe(xlCategory).Select
With Selection.Format.TextFrame2.TextRange.Font 'Run-Time error: method of object failed
.BaselineOffset = 0
.Bold = msoTrue
.Size = 12
.Italic = msoFalse
End With
However using the With-EndWith statemnt is giving me a run-time error.
Therefore, I'd like to know if there is any code that is equivalent to the code above. I am using Excel 2013.
if your goal is to simply change TickLabels font, may try something like this
ActiveSheet.ChartObjects("myChart").Activate
Dim Axx As Axis
Set Axx = ActiveChart.Axes(xlCategory)
With Axx.TickLabels.Font
.Bold = True
.Size = 12
.Name = "Bookman Old Style"
.Italic = False
.Color = RGB(255, 0, 0)
End With
I want to create ActiveX objects directly on a worksheet. I can do this programmatically.
I also want several controls grouped together with a particular background. I created them within a Frame object: i.e. the controls would be "child objects" of the frame.
The following sample code does the job:
Sub CreateFormOnSheet()
With ActiveSheet
' Add the frame background:
.OLEObjects.Add(ClassType:="Forms.Frame.1", Left:=10, Top:=10, Width:=300, Height:=300).Name = "container_frame"
With .OLEObjects("container_frame")
With .Object
.Caption = "This is the frame caption"
.BackColor = RGB(150, 0, 100)
.BorderColor = RGB(255, 255, 255)
.Controls.Add("Forms.CommandButton.1").Name = "MyButton"
With .Controls("MyButton")
.Left = 10
.Top = 10
.Width = 100
.Height = 50
.BackColor = RGB(0, 0, 100)
.ForeColor = RGB(255, 255, 255)
.Caption = "My Button"
.FontName = "Arial"
.Font.Bold = True
.Font.Size = 10
.WordWrap = True
End With
End With
End With
End With
End Sub
The problem is: at the end of code execution, MyButton acts as if it's "locked", or disabled. The user can not click on it. There is no "button press" animation, of the sort that accompanies CommandButton objects.
Adding .Enabled = True does not fix this. It is already enabled, it just acts like it's not.
If I manually enter "Design Mode" - and then exit again - the button enables.
I found out how to programmatically enable/disable Design Mode:
Sub testEnter()
EnterExitDesignMode True
End Sub
Sub testExit()
EnterExitDesignMode False
End Sub
Sub EnterExitDesignMode(bEnter As Boolean)
Dim cbrs As CommandBars
Const sMsoName As String = "DesignMode"
Set cbrs = Application.CommandBars
If Not cbrs Is Nothing Then
If cbrs.GetEnabledMso(sMsoName) Then
If bEnter <> cbrs.GetPressedMso(sMsoName) Then
cbrs.ExecuteMso sMsoName
Stop
End If
End If
End If
End Sub
... however if I add the lines:
testEnter
DoEvents
testExit
... to the end of my Sub, the problem remains. Even if it worked, that seems like a hack. I'd much rather understand what's going on here, and apply a proper solution.
I think this is an known issue with adding OLEObjects, workaround is to toggle between not visible and visible. In this case for your Frame. (or method mentioned in comment above)
Sub CreateFormOnSheet()
With ActiveSheet
' Add the frame background:
.OLEObjects.Add(ClassType:="Forms.Frame.1", Left:=10, Top:=10, Width:=300, Height:=300).Name = "container_frame"
With .OLEObjects("container_frame")
With .Object
.Caption = "This is the frame caption"
.BackColor = RGB(150, 0, 100)
.BorderColor = RGB(255, 255, 255)
.Controls.Add("Forms.CommandButton.1").Name = "MyButton"
With .Controls("MyButton")
.Left = 10
.Top = 10
.Width = 100
.Height = 50
.BackColor = RGB(0, 0, 100)
.ForeColor = RGB(255, 255, 255)
.Caption = "My Button"
.FontName = "Arial"
.Font.Bold = True
.Font.Size = 10
.WordWrap = True
End With
End With
.Visible = False 'toggle the Frame
.Visible = True
End With
'or Sheets(1).Activate
'or .Activate
End With
End Sub
See also:
https://www.excelforum.com/excel-programming-vba-macros/679211-cant-enter-break-mode-at-this-time-error.html#post2073900
It is also not possible to step through with F8
I'm adding ".jpg" files to my Excel sheet with the code below :
'Add picture to excel
xlApp.Cells(i, 20).Select
xlApp.ActiveSheet.Pictures.Insert(picPath).Select
'Calgulate new picture size
With xlApp.Selection.ShapeRange
.LockAspectRatio = msoTrue
.Width = 75
.Height = 100
End With
'Resize and make printable
With xlApp.Selection
.Placement = 1 'xlMoveAndSize
'.Placement = 2 'xlMove
'.Placement = 3 'xlFreeFloating
.PrintObject = True
End With
I don't know what I am doing wrong but it doesn't get inserted into the right cell, so what should I do to put this picture into a specified cell in Excel?
Try this:
With xlApp.ActiveSheet.Pictures.Insert(PicPath)
With .ShapeRange
.LockAspectRatio = msoTrue
.Width = 75
.Height = 100
End With
.Left = xlApp.ActiveSheet.Cells(i, 20).Left
.Top = xlApp.ActiveSheet.Cells(i, 20).Top
.Placement = 1
.PrintObject = True
End With
It's better not to .select anything in Excel, it is usually never necessary and slows down your code.
Looking at posted answers I think this code would be also an alternative for someone. Nobody above used .Shapes.AddPicture in their code, only .Pictures.Insert()
Dim myPic As Object
Dim picpath As String
picpath = "C:\Users\photo.jpg" 'example photo path
Set myPic = ws.Shapes.AddPicture(picpath, False, True, 20, 20, -1, -1)
With myPic
.Width = 25
.Height = 25
.Top = xlApp.Cells(i, 20).Top 'according to variables from correct answer
.Left = xlApp.Cells(i, 20).Left
.LockAspectRatio = msoFalse
End With
I'm working in Excel 2013. Also realized that You need to fill all the parameters in .AddPicture, because of error "Argument not optional". Looking at this You may ask why I set Height and Width as -1, but that doesn't matter cause of those parameters are set underneath between With brackets.
Hope it may be also useful for someone :)
If it's simply about inserting and resizing a picture, try the code below.
For the specific question you asked, the property TopLeftCell returns the range object related to the cell where the top left corner is parked. To place a new image at a specific place, I recommend creating an image at the "right" place and registering its top and left properties values of the dummy onto double variables.
Insert your Pic assigned to a variable to easily change its name. The Shape Object will have that same name as the Picture Object.
Sub Insert_Pic_From_File(PicPath as string, wsDestination as worksheet)
Dim Pic As Picture, Shp as Shape
Set Pic = wsDestination.Pictures.Insert(FilePath)
Pic.Name = "myPicture"
'Strongly recommend using a FileSystemObject.FileExists method to check if the path is good before executing the previous command
Set Shp = wsDestination.Shapes("myPicture")
With Shp
.Height = 100
.Width = 75
.LockAspectRatio = msoTrue 'Put this later so that changing height doesn't change width and vice-versa)
.Placement = 1
.Top = 100
.Left = 100
End with
End Sub
Good luck!
I have been working on a system that ran on a PC and Mac and was battling to find code that worked for inserting pictures on both PC and Mac. This worked for me so hopefully someone else can make use of it!
Note: the strPictureFilePath and strPictureFileName variables need to be set to valid PC and Mac paths Eg
For PC: strPictureFilePath = "E:\Dropbox\" and strPictureFileName = "TestImage.jpg" and with Mac: strPictureFilePath = "Macintosh HD:Dropbox:" and strPictureFileName = "TestImage.jpg"
Code as Follows:
On Error GoTo ErrorOccured
shtRecipeBrowser.Cells(intDestinationRecipeRowCount, 1).Select
ActiveSheet.Pictures.Insert(Trim(strPictureFilePath & strPictureFileName)).Select
Selection.ShapeRange.Left = shtRecipeBrowser.Cells(intDestinationRecipeRowCount, 1).Left
Selection.ShapeRange.Top = shtRecipeBrowser.Cells(intDestinationRecipeRowCount, 1).Top + 10
Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.Height = 130
Firstly, of all I recommend that the pictures are in the same folder as the workbook.
You need to enter some codes in the Worksheet_Change procedure of the worksheet. For example, we can enter the following codes to add the image that with the same name as the value of cell in column A to the cell in column D:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim pic As Picture
If Intersect(Target, [A:A]) Is Nothing Then Exit Sub
On Error GoTo son
For Each pic In ActiveSheet.Pictures
If Not Application.Intersect(pic.TopLeftCell, Range(Target.Offset(0, 3).Address)) Is Nothing Then
pic.Delete
End If
Next pic
ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\" & Target.Value & ".jpg").Select
Selection.Top = Target.Offset(0, 2).Top
Selection.Left = Target.Offset(0, 3).Left
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = Target.Offset(0, 2).Height
Selection.ShapeRange.Width = Target.Offset(0, 3).Width
son:
End Sub
With the codes above, the picture is sized according to the cell it is added to.
Details and sample file here : Vba Insert image to cell
I tested both #SWa and #Teamothy solution. I did not find the Pictures.Insert Method in the Microsoft Documentations and feared some compatibility issues. So I guess, the older Shapes.AddPicture Method should work on all versions. But it is slow!
On Error Resume Next
'
' first and faster method (in Office 2016)
'
With ws.Pictures.Insert(Filename:=imageFileName, LinkToFile:=msoTrue, SaveWithDocument:=msoTrue)
With .ShapeRange
.LockAspectRatio = msoTrue
.Width = destRange.Width
.height = destRange.height '222
End With
.Left = destRange.Left
.Top = destRange.Top
.Placement = 1
.PrintObject = True
.Name = imageName
End With
'
' second but slower method (in Office 2016)
'
If Err.Number <> 0 Then
Err.Clear
Dim myPic As Shape
Set myPic = ws.Shapes.AddPicture(Filename:=imageFileName, _
LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, _
Left:=destRange.Left, Top:=destRange.Top, Width:=-1, height:=destRange.height)
With myPic.OLEFormat.Object.ShapeRange
.LockAspectRatio = msoTrue
.Width = destRange.Width
.height = destRange.height '222
End With
End If