i have problem with selecting combobox after creating it via shapes object. Can someone please help?
My code is
Dim comboBoxRange As Range
Set comboBoxRange = Sheets(axleDataWindowName).Range("F2:F4")
currentSheet.DropDowns.Add(20, 40, 100, 15).Name = "modifiedComboBox"
With currentSheet.Shapes("modifiedComboBox")
.Left = 450
.List comboBoxRange.Value
End With
You need to call currentSheet.Dropdowns("modifiedComboBox") instead of currentSheet.Shapes("modifiedComboBox"). Also use .AddItem instead of .List:
Dim comboBoxRange As Range
Set comboBoxRange = Sheets(axleDataWindowName).Range("F2:F4")
currentSheet.DropDowns.Add(20, 40, 100, 15).Name = "modifiedComboBox"
With currentSheet.Shapes("modifiedComboBox")
.Left = 450
.AddItem comboBoxRange.Value
End With
Related
So, I'm trying to create "cards" that the user can move around even when the the workbook is locked. Each card will contain info about a certain project.
The way I'm doing it:
Create a few shapes (an rectangle and a few labels and icons)
Group them
Cut the group
Paste as image
The problem is that when I paste as image, all labels loose their text, they change back to "label1".
If I run the code line by line, they don't lose the text.
I've tried already to add "time" between the cut and paste, adding some lines of code, moving the paste line to a separated sub, and even using Application.Wait(), but nothing worked.
I need to have them as an image (or one solid object - just a group doesn't work), because after the macro is finished, the worksheet is locked back again, and there is another macro to allow the user to move shapes even when the workbook is locked.
Here is a sample to show the problem.
Sub MyCode()
Set wkm = Workbooks(ThisWorkbook.Name)
Set wsm = wkm.Worksheets("TestSheet")
'Just two labels as exemple, the original code has more labels, more icons, and the rounded rectangle)
'The values for the constructors in the original code are defined by the user by a forms
Call GenerateLabel("plaseWork", "Name of the project", 14, 30)
Call GenerateLabel("whyCantYouJustWork", "Name of the user", 42, 30)
wsm.Shapes.Range(Array("plaseWork", "whyCantYouJustWork")).Group.Name = "myGroup"
Set freeSlot = wsm.Range("B10") 'Just a random cell, in the original code there is a function to define the position
Application.CutCopyMode = False
wsm.Shapes("myGroup").Cut
With wsm.Pictures.Paste
.left = freeSlot.left
.top = freeSlot.top
End With
Application.CutCopyMode = False
Set card = wsm.Pictures(wsm.Pictures.Count)
card.Name = "card" & projectName
End Sub
Sub GenerateLabel(labelDescription As String, projectName As String, top As Integer, left As Integer)
Set lbLabel = wsm.OLEObjects.Add(ClassType:="Forms.Label.1")
With lbLabel
.Name = labelDescription
.Object.BackStyle = fmBackStyleTransparent
.Width = 160
.top = top
.left = left
End With
With wsm
.OLEObjects(lbLabel.Name).Object.Caption = projectName
.Shapes(lbLabel.Name).Fill.Transparency = 1
End With
End Sub
What about using shapes with no outline or fill, in place of labels?
Sub MyCode()
Dim wsm As Worksheet, arr(0 To 1), grp As Shape
Set wkm = Workbooks(ThisWorkbook.Name)
Set wsm = wkm.Worksheets("TestSheet")
arr(0) = AddLabel(wsm, "Name of the project", 14, 30).Name
arr(1) = AddLabel(wsm, "Name of the user", 42, 30).Name
Set freeSlot = wsm.Range("B10") 'Just a random cell, in the original code there is a function to define the position
wsm.Shapes.Range(arr).Group.Cut
With wsm.Pictures.Paste
.left = freeSlot.left
.top = freeSlot.top
End With
Set card = wsm.Pictures(wsm.Pictures.Count)
card.Name = "card" & projectName
End Sub
'Add a shape to a worksheet, with the text provided.
' Return the added shape
Function AddLabel(ws As Worksheet, projectName As String, top As Integer, left As Integer)
Dim shp
Set shp = ActiveSheet.Shapes.AddShape(msoShapeRectangle, left, top, 160, 30)
With shp
.Fill.Visible = msoFalse
.Line.Visible = msoFalse
With .TextFrame2.TextRange.Characters
.Text = projectName
.Font.Fill.ForeColor.RGB = vbBlack
.Font.Size = 14
End With
End With
Set AddLabel = shp
End Function
I have inserted textbox under insert --> shapes----> Textbox. now I want to resize textbox font if text-overflow textbox. I tried the following codes.
With Selection
If .TextFrame.HorizontalOverflow = msoTrue Then
Do
.TextFrame2.TextRange.Font.Size = .TextFrame2.TextRange.Font.Size - 1
Loop Until .TextFrame.HorizontalOverflow = msoFalse
End If
End with
ps: its Barcode font. so if it gets wrap then it's not readable by a barcode reader. so I want to shrink it.
But no success.
Thanks
The code below seems to achieve what you are looking for for standard text. Maybe you can extract the principle and use it with your barcode style.
Option Explicit
Sub AdjustTextInTextBox()
Dim myWs As Worksheet
Set myWs = ThisWorkbook.ActiveSheet
myWs.Shapes.AddShape msoTextBox, 100, 100, 250, 50
Dim myShape As Shape
Set myShape = myWs.Shapes.Item(1)
myShape.TextFrame2.AutoSize = msoAutoSizeShapeToFitText
Dim myHeight As Long
myHeight = myShape.Height
myShape.TextFrame2.TextRange.Text = "Hello world its a really really really nice day"
Do While myShape.Height > myHeight
myShape.TextFrame2.TextRange.Font.Size = myShape.TextFrame2.TextRange.Font.Size - 1
Loop
End Sub
I use the following VBA to insert two buttons into my Excel sheet and group them together:
Sub Insert_Buttons()
Sheet1.Select
Dim Button_01 As Button
Set Button_01 = Sheet1.Buttons.Add(423.75, 0, 48, 15)
Dim Range_Button_01 As Range
Set Range_Button_01 = Sheet1.Range("B6:D7")
Button_01.Name = "Button_01"
With Button_01
.Top = 30
.Left = 76
.Width = 50
.Height = 20
.Text = "Button_01"
End With
Sheet1.Select
Dim Button_02 As Button
Set Button_02 = Sheet1.Buttons.Add(423.75, 0, 48, 15)
Dim Range_Button_02 As Range
Set Range_Button_02 = Sheet1.Range("B6:D7")
Button_02.Name = "Button_02"
With Button_02
.Top = 5
.Left = 76
.Width = 50
.Height = 10
.Text = "Button_02"
Sheet1.Shapes.Range(Array("Button_01", "Button_02")).Group
End Sub
All this works perfectly.
However, now I want to use another VBA to ungroup the buttons which I inserted with the above VBA. Therefore, I tried to go with the following:
Sub Ungroup_Buttons()
Sheet1.Shapes.Range(Array("Button_01", "Button_02")).Ungroup
End Sub
However, with this VBA I get runtime error 1004.
What do I need to change in my code so I can ungroup the buttons?
Maybe give this a try :
Sub Ungroup_Buttons()
Set ButtonList = Sheet1.Shapes.Range(Array("Button_01", "Button_02")).Group
ButtonList.Name= "ListToUnGroup"
Sheet1.Shapes.Range("ListToUnGroup").Ungroup
End Sub
I've an excel vba form named as 'UserForm'. Overall, there's a button (name as 'buttonAdd') that the function could create/add textbox based on inputed (from 'a' variabel) value dynamically. Here's the code.
Public Sub buttonAdd_Click()
Dim a As Integer
a = TextBox1.Value
Dim cCntrl As Control
For i = 1 To a
Set cCntrl = Me.Controls.Add("Forms.TextBox.1", "quarter", True)
With cCntrl
.Name = "quarter" & d
.Width = 150
.Height = 25
.Top = 100 + (d * 25)
.Left = 220
.ZOrder (0)
End With
Next i
Now, I've a problem. I can't take/get the value from those dynamic textbox. I tried using this code for saving the value into 'A1' cell, but it's doesnt work.
Private Sub SaveButton_Click()
Dim a As Integer
Dim Ws As Worksheet
Dim cCntrl As Control
Set Ws = Worksheets("Sheet1")
Ws.Range("A1").Value = quarter1.Value
End Sub
I thought the name of first dynamic textbox is quarter1, but when I tried to get the value, it didn't work. Is there anyway or hint for solving this issue. Just saying: just take the value of the first text box, write it there, then take another one and so on.
Thanks a lot.
Looks like your problem is a simple typo. You have used d instead of i (d is undefined in your code). I recommend always using Option Explicit.
Public Sub buttonAdd_Click()
Dim a As Long ' Minor, but Integer I sjust too short these days for a lot of things.
Dim i as Long
a = TextBox1.Value
Dim cCntrl As Control
For i = 1 To a
Set cCntrl = Me.Controls.Add("Forms.TextBox.1", "quarter", True)
With cCntrl
.Name = "quarter" & CStr(i) ' explicit rather than implicit conversion
.Width = 150
.Height = 25
.Top = 100 + (i * 25)
.Left = 220
.ZOrder (0)
End With
Next I
Edit: Might be a couple more typos in the .Add command (e.g. you might have wanted "quarter" & "1" instead of just "quarter"?) but I don't have the VBA reference up at the moment to check.
I'm currently trying to auto name the objects from a referenced list rather than just have the object text stated in the script.
How do I get the script to reference a separate worksheet called Process Steps where the text value is in cell C7 instead of entering the statement in the script as Step 1
ActiveSheet.Shapes.AddShape(msoShapeRectangle, 50, 50, 100, 50).Select
Selection.Formula = ""
Selection.ShapeRange.ShapeStyle = msoShapeStylePreset40
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = "Step1"
Peter has already mentioned how to pick up a value from another cell. Taking this a bit ahead.
Please avoid the use of .Select/.Activate INTERESTING READ
Is this what you are trying?
Sub Sample()
Dim shp As Shape
Set shp = ActiveSheet.Shapes.AddShape(msoShapeRectangle, 50, 50, 100, 50)
With shp.OLEFormat.Object
.Formula = ""
.ShapeRange.ShapeStyle = msoShapeStylePreset40
.ShapeRange(1).TextFrame2.TextRange.Characters.Text = _
ThisWorkbook.Sheets("Process Steps").Range("C7").Value
End With
End Sub