VBA Excel Changing the features of textbox with formula - excel

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

Related

Copy Excel text to PowerPoint without copying the text inside the parenthesis

I have written a code (excel VBA) to output powerpoint report. Part of the code is to create a table, then supply the data into it from the excel. My problem now is copying a certain data from excel. I do not want to copy any information inside the parenthesis as well as the parenthesis itself. For example, the data is the name of the employee together with their employee ID. I just need the employee's name. Do you know how to do it?
Below is part of the code. It's quite long since im still new in VBA coding. From the code below, the last part .Text = Range("F1") is the code where I will copy the data I will translate to the powerpoint.
Set myShape = myPresentation.Slides(2).Shapes.AddTable(10, 4, 50, 100, 800)
myShape.Table.Rows.Add
myShape.Height = 0
With myShape.Table
.Cell(1, 1).Merge MergeTo:=.Cell(1, 2)
.Cell(1, 2).Merge MergeTo:=.Cell(1, 3)
.Cell(1, 3).Merge MergeTo:=.Cell(1, 4)
With .Cell(1, 4).Shape
With .TextFrame.TextRange
.Text = "General Information"
.Font.Size = 13
.Font.Name = "Arial"
.Font.Color = RGB(0, 0, 0)
End With
End With
With .Cell(2, 1).Shape
With .TextFrame.TextRange
.Text = "FA Site"
.Font.Size = 13
.Font.Name = "Arial"
.Font.Color = RGB(0, 0, 0)
End With
End With
With .Cell(2, 2).Shape
With .TextFrame.TextRange
.Text = "Singapore"
.Font.Size = 13
.Font.Name = "Arial"
.Font.Color = RGB(0, 0, 0)
End With
End With
With .Cell(2, 3).Shape
With .TextFrame.TextRange
.Text = Range("F1")
.Font.Size = 13
.Font.Name = "Arial"
.Font.Color = RGB(0, 0, 0)
End With
End With
I dont know how to write the VBA code for this problem. I hope someone can help me.
As a possible answer, depending on your reply to my comment earlier, here's a function that will return the original text you pass to it with any text between open and close parentheses removed.
It's not very robust; you'll want to add further checks to make sure that, for example, there ARE both open and close parens in the string.
Function RemoveParens(sText As String) As String
Dim sTemp As String
Dim lParenStart As Long
Dim lParenEnd As Long
Dim sParentheticalText As String
lParenStart = InStr(sText, "(")
lParenEnd = InStr(sText, ")")
sTemp = Mid$(sText, 1, lParenStart - 1)
sTemp = sTemp & Mid$(sText, lParenEnd + 1)
RemoveParens = sTemp
End Function
Here is another option. It has it's pros and cons.
Pros:
*** Will work on multiple strings! Will not remove parts you want to keep in between bracketed areas, and will always remove all bracketed areas.
Will not throw errors if nothing to remove (might also be a con in some situations)
Short easy to use/edit function
Cons:
You need to have a cell free to use for the calculations (Either A1 on a hidden sheet, or some cell you know is free
Slow for large datasets, This takes about half a second per string on a slow work computer. if you're only dealing with =< 50 strings, great! otherwise this would take a few minutes to calculate. This may actually be the slowest way to do this calculation.
Option Explicit
Sub TextToStrip()
Debug.Print StripOutParaText("Test (ouch) and Some ( dog) Number 1")
' Output = "Test and Some Number 1"
End Sub
Function StripOutParaText(RefText As String) As String
Dim RG As Range
Set RG = Worksheets("Data").Range("A1")
RG.Value = RefText
RG.Replace " (*)", "", xlPart
StripOutParaText = RG.Value
End Function

ExcelApp.Visible causing Error 91 and I can't figure out how to fix it

A little background:
A former employee wrote a VBA program to run in AutoCAD to generate G-code based off of CAD entities. The immediate problem is that it currently only runs in AutoCAD 2002 on a computer running Windows XP on a virtual desktop. Obviously, that doesn't work so I'm trying to get it to work on BricsCad V21. My current issue is that I keep getting a Run time error 91 at the following place and I do not understand what the issue is or how to overcome it.
Please note that I am a VERY beginner programmer and am still trying to wrap my head around how all of this works. Any help you can provide would be most appreciated.
Public ExcelApp As Excel.Application
Public wbkObj As Excel.Workbook
Public shtObj As Excel.Worksheet
Public rngObj As Excel.Range
These are the relevant declarations at the beginning of the program
Sub CAM_A_CHEST()
Set ExcelApp = CreateObject("Excel.Application")
Set wbkObj = ExcelApp.workbooks.Add
Set shtObj = ExcelApp.Worksheets(1)
If Err <> 0 Then
MsgBox "Could not start Excel", vbExclamation
End
Else
ExcelApp.Visible = True
Application.Visible = True
ExcelApp.ScreenUpdating = True
Set rngObj = shtObj.Range(Cells(1, 1), Cells(1, 5))
With rngObj
.NumberFormat = "0"
.Font.Name = "Arial"
.Font.FontStyle = "Bold"
.Font.Size = 10
'.Font.ColorIndex = xlAutomatic
End With
With shtObj.Range(Cells(2, 1), Cells(2000, 13))
.NumberFormat = "0.000"
.Font.Name = "Arial"
.Font.FontStyle = "Regular"
.Font.Size = 9
.Value = ""
End With
With shtObj.Range(Cells(2, 5), Cells(2000, 5))
.NumberFormat = "0"
End With
shtObj.Range("A1:D1").Select
Selection.NumberFormat = "General"
shtObj.Cells(1, 1).ColumnWidth = 18
shtObj.Cells(1, 1) = "Layer"
shtObj.Cells(1, 2) = "Center X"
shtObj.Cells(1, 3) = "Center Y"
shtObj.Cells(1, 4) = "Diameter"
shtObj.Cells(1, 5) = "Sort"
shtObj.Cells(1, 7).Font.FontStyle = "Bold"
shtObj.Cells(1, 7).Font.Size = 10
Range("A2").Select
ActiveWindow.FreezePanes = True
End If
'ExcelApp.Visible = False
transZ$ = "2.00"
divNum$ = ""
grpNum$ = "0"
Load UserForm1
Load UserForm2
Load UserForm3
Load procUserForm
Call UserForm_Initialize
That is the chunk of code that opens Excel, formats the Worksheet, and prepares for inputs from AutoCAD. Later on in the code, The following Sub is called:
Sub CAM_TopAndBottomBoards()
Dim I As Integer
Dim mspaceObj As AcadObject
Dim centerPoint As Variant
Dim ExcelApp As Excel.Application
increment = 0
Call InitializeCounters
SelectStuff:
'Find entities representing Pitman Holes, Pipe Holes, etc., among items selected,
' dump data into Excel sheet
ExcelApp.Visible = True
It's that last line that is generating the error.
At this point I've spent a couple of days on this issue and I'm completely stuck. Help!

Is there a more efficient way of doing what is listed in the code below?

Ok so I've googled this and checked on here, but there is nothing similar to what I need looking at and i'm not familiar with VBA, only Python.
In python I would select the data and put it into a list, then do my stuff, then retrieve the data from the list and apply it. What I'm asking is whether there is a way to simplify the below code using arrays; if there is what would be the best way to do that. This code has 5 of these for loops, which I think is where we are losing the efficiency. Currently the macro will take 10 minutes to run once. I have a feeling that is because the for loops here refresh the page for each cell selection? i might be wrong with that. I'm happy to post more code and even the spreadsheet if required. Rally appreciate anyone taking the time to have a look at this!
Set ar = Selection
For Each ar In ar.Rows
newHeight = ar.RowHeight + 12.5
ar.VerticalAlignment = xlTop
ar.RowHeight = newHeight
Next ar
For Each Row1 In Sheets("ReportSummary").Range("4:26").Rows
If Row1.Cells(1, 2).Value = "" Then Row1.RowHeight = 0
Next
Sheets("ReportSummary").Select
Sheets("ReportSummary").Range("F4:F26").WrapText = True
Sheets("ReportSummary").Range("F4:F26").EntireRow.AutoFit
Sheets("ReportSummary").Range("F4:F26").Select`
This is one way to do it:
Sub test()
'turn off unnecessary stuff
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
On Error GoTo whoops 'if there's an error make sure we turn it all back on again
Dim ar As Range
Dim x As Long
Set ar = Selection
For x = ar.Row To ar.Row + ar.Rows.Count - 1
With ar.Rows(x)
.RowHeight = .RowHeight + 12.5
.VerticalAlignment = xlTop
End With
Next x
With Sheets("ReportSummary")
For x = 4 To 26
If .Cells(x, 2) = "" Then .Rows(x).RowHeight = 0
Next x
With .Range("F4:F26")
.WrapText = True
.EntireRow.AutoFit
End With
End With
whoops:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub

Form object in container frame on worksheet inactive unless Design Mode manually toggled

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

setting color to a comment's characters in vba

I need to copy a cell in Excel from one range to another range's comment, while keeping its format (size, bold, color, italic...).
My piece of code works, except for color, which throws a Run-Time error '1004':
Font size must be between 1 and 409 points.
Which is strange, because size works, and if I comment out color lines (') it works.
Here is my code:
Option Explicit
Function Comment_Format(ByVal Rg_Value As Range, ByVal Rg_Com As Range) As Comment
Dim i As Long, a As Long
If Rg_Com.Comment Is Nothing Then Rg_Com.AddComment
With Rg_Com.Comment
.Text Text:=Rg_Value.Value2
.Shape.TextFrame.AutoSize = True
End With
For i = 1 To Len(Rg_Value.Value2)
With Rg_Com.Comment.Shape.TextFrame.Characters(i, 1).Font
.Size = Rg_Value.Characters(i, 1).Font.Size
'a = Rg_Value.Characters(i, 1).Font.Color
'If a > 0 Then .Color = a ' <<<<<<<<<<<<<<< this line shows the error !!
.FontStyle = Rg_Value.Characters(i, 1).Font.FontStyle
End With
Next i
Set Comment_Format = Rg_Com.Comment
End Function
Sub test()
Dim com As Comment
Set com = Comment_Format(Range("a1"), Range("b1"))
End Sub
Thanks for your help.
I had better luck using ColorIndex rather than Color and coloring first:
Sub MAIN2()
Call Comment_Format(Range("a1"), Range("b1"))
End Sub
Sub Comment_Format(Rg_Value As Range, Rg_Com As Range)
Dim i As Long
With Rg_Com
.ClearComments
.AddComment
.Comment.Text Text:=Rg_Value.Text
L = Len(Rg_Value.Text)
For i = 1 To L
.Comment.Shape.TextFrame.Characters(i, 1).Font.ColorIndex = Range("A1").Characters(i, 1).Font.ColorIndex
Next i
End With
For i = 1 To L
With Rg_Com.Comment.Shape.TextFrame.Characters(i, 1).Font
.Size = Rg_Value.Characters(i, 1).Font.Size
.Bold = Rg_Value.Characters(i, 1).Font.Bold
.Italic = Rg_Value.Characters(i, 1).Font.Italic
End With
Next i
End Sub
Which for me gave:
EDIT#1:
There appears to be a bug in Excel 2007 / Win 7 in the processing of Color with Comments
I finally found the solution and why a color line of code would rise a 'size' error.
I did like you, first color it all and then a second loop,
but added the autosize before the first loop (because my text is BIG) , then color loop,
then the 2nd loop (including size),
and then doing a second autosize=true because of course size changed !
i think its kind of like trying to select a cell in a hidden sheet, just applyed to comments
(the color property might rewrite every active pixel color but he cant 'read' a hidden pixel (being out of comment's shape size), am i making any sense to you?)
final code, working (any size of text):
Option Explicit
Function Comment_Format(ByVal Rg_Value As Range, ByVal Rg_Com As Range) As Comment
'Set Rg_Value = Range("A1") 'origin of the text
'Set Rg_Com = Range("b1") 'destination cell containing the comment
Dim i As Long 'simple loop counter
Dim ff As Font 'i used a variable for the long repeating garbage code (Rg_Value.Characters(i, 1).Font)
Dim L As Long ' lenght of text (mine is 508 in my sample)
If Rg_Com.Comment Is Nothing Then Rg_Com.AddComment
With Rg_Com
.ClearComments
.AddComment
With .Comment
.Text Text:=Rg_Value.Text
.Shape.TextFrame.AutoSize = True '<<< just to make all text visible in one comment, all chars having the basic size
End With
End With
'On Error Resume Next
L = Len(Rg_Value.Text)
For i = 1 To L
Set ff = Rg_Value.Characters(i, 1).Font
With Rg_Com.Comment.Shape.TextFrame.Characters(i, 1).Font
.ColorIndex = ff.ColorIndex
End With
Next i
For i = 1 To L
Set ff = Rg_Value.Characters(i, 1).Font
With Rg_Com.Comment.Shape.TextFrame.Characters(i, 1).Font
.Size = ff.Size
.Bold = ff.Bold
.Italic = ff.Italic
.Underline = ff.Underline
End With
Next i
Rg_Com.Comment.Shape.TextFrame.AutoSize = True ' <<< now chars of the comment's text already have different sizes, and i need to resize the shape
'On Error GoTo 0
Set Rg_Value = Nothing
Set Rg_Com = Nothing
End Function
Sub test()
Dim com As Comment
With Application
.EnableEvents = False
.ScreenUpdating = False 'tryed to make it faster, but still uber slow (25 seconds for my 508 characters sample text)
.Calculation = xlCalculationManual
End With
Set com = Comment_Format(Range("a1"), Range("b1"))
Beep 'wakes me up when the looping is over
Set com = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub

Resources