Change font and font size during creating userform programatically - excel

I am going to create a userform programmatically, I am able to create other controls like commandbuttons, textboxes, optionbuttons...etc., as my wish.
But I can not figure out the way to set the font and font size at the beginning of creating the userform programmatically.
As there are near hundred controls, it would be better for me to set the font at the beginning, otherwise, I may set the font manually afterwards.
I tried the following for setting:
Dim NewForm As Object
Application.VBE.MainWindow.Visible = True
Set NewForm = ThisWorkbook.VBProject.VBComponents.Add(vbext_ct_MSForm)
With NewForm
.Properties("Caption") = ""
.Properties("Width") = 400
.Properties("Height") = 400
------> 'Properties("Font.Name") = "Arial"
'Properties("Font.size") = 9
'Or
------> '.Font = "Arial"
'.font.size = 9
.Name = "frmWebScraping"
End With
'code for creating other controls with no problem is neglected
End Sub

The correct properties are:
.Properties("Font").Value.Item("Name") = "Arial"
.Properties("Font").Value.Item("Size") = 9

Related

Excel VBA copy Text Box (Text and Format) to another Text Box (no ActiveX / User Forms)

I am trying to copy the contents (text and format) from a text box on one sheet to another text box on another sheet within the same workbook. I have been able to successfully copy over almost everything, but the justification (center/left/right) is not working for each individual line. I am doing this in a very clunky way: copy the text, then loop through each character to get the format set. There does not seem to be an easy way in excel vba to copy both the text and ALL of the format over. Essentially I am trying to do a "select all (Cntrl-A)", "copy (Cnrl-C)" on the origin textbox, then do a "paste special (keep source formatting)" on the destination text box. IT works wonderfully using the mouse, but I do not want to do that. I just want to run a macro to do the same thing. Also, I noted that when the macro runs, the destination text box applies justification global to the text and I am no longer able to individually select a single line and set its justification (i.e. either all lines are centered or all lines are left justified vs. being able to adjust each line individually). Again, this weird behavior only happens after the macro is run. If I use the mouse cut-and-paste method, the text is able to be justified line-by-line again. Here is my clunky code:
Sub Update_CARD_LEG_BACK()
' Set varibles to reduce typing and make changing origin and destination text boxes easier.
Set Orig = Sheets("MAIN_INPUT2").Shapes("CARD_LEG_BACK")
Set Orig_Sheet = Sheets("MAIN_INPUT2")
Set Dest = Sheets("CARD_LEGACY").Shapes("BACK")
Set Dest_Sheet = Sheets("CARD_LEGACY")
'Copy text from origin text box to destination text box. Copies only the text NO formating.
Dest.TextFrame.Characters.Text = Orig.TextFrame.Characters.Text
For i = 1 To Len(Orig.TextFrame.Characters.Text)
Dest.TextFrame.Characters(i, 1).Font.Underline = Orig.TextFrame.Characters(i, 1).Font.Underline
With Dest.TextFrame2.TextRange.Characters(i, 1)
.Text = Orig.TextFrame2.TextRange.Characters(i, 1).Text
With .Font
.Name = Orig.TextFrame2.TextRange.Characters(i, 1).Font.Name
.Size = Orig.TextFrame2.TextRange.Characters(i, 1).Font.Size
.Bold = Orig.TextFrame2.TextRange.Characters(i, 1).Font.Bold
.Strikethrough = Orig.TextFrame2.TextRange.Characters(i, 1).Font.Strikethrough
.Superscript = Orig.TextFrame2.TextRange.Characters(i, 1).Font.Superscript
.Subscript = Orig.TextFrame2.TextRange.Characters(i, 1).Font.Subscript
.Fill.ForeColor.RGB = Orig.TextFrame2.TextRange.Characters(i, 1).Font.Fill.ForeColor.RGB
.Fill.BackColor.RGB = Orig.TextFrame2.TextRange.Characters(i, 1).Font.Fill.BackColor.RGB
.Fill.Visible = Orig.TextFrame2.TextRange.Characters(i, 1).Font.Fill.Visible
.Fill.Transparency = Orig.TextFrame2.TextRange.Characters(i, 1).Font.Fill.Transparency
End With
With .ParagraphFormat
.BaselineAlignment = Orig.TextFrame2.TextRange.Characters(i, 1).ParagraphFormat.BaselineAlignment
.SpaceWithin = Orig.TextFrame2.TextRange.Characters(i, 1).ParagraphFormat.SpaceWithin
.SpaceBefore = Orig.TextFrame2.TextRange.Characters(i, 1).ParagraphFormat.SpaceBefore
.SpaceAfter = Orig.TextFrame2.TextRange.Characters(i, 1).ParagraphFormat.SpaceAfter
.IndentLevel = Orig.TextFrame2.TextRange.Characters(i, 1).ParagraphFormat.IndentLevel
.FirstLineIndent = Orig.TextFrame2.TextRange.Characters(i, 1).ParagraphFormat.FirstLineIndent
.Alignment = Orig.TextFrame2.TextRange.Characters(i, 1).ParagraphFormat.Alignment
.HangingPunctuation = Orig.TextFrame2.TextRange.Characters(i, 1).ParagraphFormat.HangingPunctuation
End With
End With
Next i
'Copy fill color of origin text box to destination text box. Also copies transparancy (required for 'no fill' option to copy correctly).
Dest.Fill.ForeColor.RGB = Orig.Fill.ForeColor.RGB
Dest.Fill.Transparency = Orig.Fill.Transparency
End Sub
You could replace the second with a copy of the first:
Sub Tester()
ReplaceWithCopy Sheet1.Shapes("SourceTB"), Sheet2.Shapes("DestTB")
End Sub
Sub ReplaceWithCopy(shpSrc As Shape, shpDest As Shape)
Dim nm As String
shpSrc.Copy
shpDest.Parent.Paste
With shpDest.Parent.Shapes(shpDest.Parent.Shapes.Count)
.Left = shpDest.Left
.Top = shpDest.Top
.Width = shpDest.Width
.Height = shpDest.Height
nm = shpDest.Name
shpDest.Delete 'remove the shape being replaced
.Name = nm 'rename copy to just-deleted shape
End With
End Sub

Shrink Text in Textbox without Wrap

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

Opening every file in a specific folder

i'm making a code for Excel that opens every file in a specific folder. When the file is open I like to add a button to each of these files at the same location. I made this code shown as below. but somehow I get this error:
Run-Time Error '1004': Unable to get the Add property of the
OLEObjects class
The code breaks on the line where it says: set addbutton = etc...
Does anyone know why?
My Code:
Dim AddButton As OLEObject
Set AddButton =
Workbooks(ThisWB).Sheets("Planning").OLEObjects.add(ClassType:="Forms.CommandButton.1", Link:=False,
DisplayAsIcon:=False, Left:=3.52941176470588, Top:=106.764705882353,
Width:=47.6470588235294, Height:=24.7058823529412)
With AddButton
.Name = "SortPlanner"
.OnAction = "SortPersonalPlanner"
With .Object
.Caption = "Sorteren"
.BackColor = &HFFFFFF
End With
End With
You can do something like this, use .Buttons.Add instead of .OLEObjects.add
Set AddButton = Workbooks(ThisWB).Sheets("Planning").Buttons.Add(3.53, 106.76, 47.65, 24.71)
With AddButton
.Characters.Text = "Sorteren"
.Font.Bold = True
.OnAction = "SortPersonalPlanner"
End With

Simulate button press effect

I have macro assigned to a rectangle shape that goes to the next sheet in my workbook.
I'm trying to add a press down and up effect to this rectangle.
When I use this code, the rectangle is only pressed down then then the next sheet is activated, and if I returned back to the previous sheet, the rectangle is released.
Wht I need is that the rectangle is pressed down and then released before going to the next sheet.
Dim MyButton As Shape
Dim oHeight, oWidth, cHeight, cWidth As Double
Dim oTop, oLeft As Long
Public Sub PressButton()
Set MyButton = ActiveSheet.Shapes(Application.Caller)
With MyButton
'Record original button properties.
oHeight = .Height
oWidth = .Width
oTop = .Top
oLeft = .Left
'Button Down (Simulate button click).
.ScaleHeight 0.9, msoFalse
.ScaleWidth 0.9, msoFalse
cHeight = .Height
cWidth = .Width
.Top = oTop + ((oHeight - cHeight) / 2)
.Left = oLeft + ((oWidth - cWidth) / 2)
End With
'Set MyButton variable to Nothing to free memory.
Set MyButton = Nothing
End Sub
Public Sub ReleaseButton()
Set MyButton = ActiveSheet.Shapes(Application.Caller)
With MyButton
'Button Up (Set back to original button properties).
.Height = oHeight
.Width = oWidth
.Top = oTop
.Left = oLeft
End With
'Set MyButton variable to Nothing to free memory.
Set MyButton = Nothing
End Sub
Public Sub NextPage()
PressButton
Application.Wait (Now + TimeSerial(0, 0, 1))
ReleaseButton
Dim ws As Worksheet
Set ws = ActiveSheet
Do While Not ws.Next.Visible = xlSheetVisible
Set ws = ws.Next
Loop
With ws.Next
.Activate
.Range("A1").Select
End With
End Sub
You're better off using a 'Command Button': shapes and rectangle objects don't really support the event-driven 'On Click' functionality you need here: calling an associated macro is pretty much all that they do.
However, you may well be stuck with that shape as your interface (support for ActiveX command buttons is very poor in 64-bit environments), so here goes...
Background: how to make a button look like a button:
Most shapes have a 'Shadow' property, and an outside shadow cast by a light source from a 45-degree angle (from the top-left corner) gives a 'raised' effect. Conversely, an inside shadow cast from the opposite angle (from a light source off the bottom-right corner) gives a 'sunken' effect.
In practice, an inside shadow for both is good enough: just change the angle.
In VBA, the 'angle' of the light source for your shape's shadow is given as X and Y offsets, and 45 degrees corresponds to 1.14142:
Dim oShape As Excel.Shape
Dim oShadow As Excel.ShadowFormat
Set oShape = ActiveSheet.Shapes(i)
Set oShadow = oShape.Shadow
' Shadow cast by light from above-right at 45 degrees for a 'raised' effect:
oShadow.OffsetX = Sqr(2)
oShadow.OffsetY = Sqr(2)
' Shadow cast by light from above-right at minus 45 degrees for a 'sunken' effect:
oShadow.OffsetX = -Sqr(2)
oShadow.OffsetY = -Sqr(2)
...And that's the code for your click 'up' and click 'down' button state.
I Strongly recommend that you use the built-in dialogs to set the shape's fill colour and the shadow's size, transparency and blur. For your reference, the settings I use for a smart 'semi-flat' light grey button are listed below - but I do not recommend that you set them in VBA code, as these formats will not be applied in the order you expect, and the button will not look like the 'clean' shape you can build using the UI dialogs:
' Light-grey button with a slightly darker 'softened' border
oShape.Fill.ForeColor.RGB = &HD8D8D8
oShape.Line.ForeColor.RGB = &HC0C0C0
oShape.Line.Weight = 2
oShape.Line.Transparency = 0.75
' Use the shape's shadow to give a 'raised button' effect:
oShadow.Style = msoShadowStyleInnerShadow
oShadow.Visible = True
oShadow.Blur = 2
oShadow.Size = 100
oShadow.Transparency = 0.5
' Shadow cast by light from above-right at 45 degrees for a 'raised' effect:
oShadow.OffsetX = Sqr(2)
oShadow.OffsetY = Sqr(2)
You can also use the 3-D effects dialog, but this works by a 'chisel' effect for most shapes (including your rectangle): I haven't found any predefined 'raised' or 'sunken' three-D styles for shapes.
Major Edit:
Guess who's looking at the job of replacing all the Active-X control buttons on all the tactical spreadsheet tools before the 64-Bit Office rollout renders them inoperable?
So your question just became very, very interesting indeed. Here's what I'm doing about that:
Generic 'Button Click' code for using Excel 'Shape' objects to call a VBA Macro instead of ActiveX controls.
This is what I'm using instead of ActiveX buttons: text labels, rectangles and images, placed into the worksheet using the 'Insert' menu on the Ribbon.
These objects are all Excel 'Shapes', they can all be associated with a named macro, and they have a common 'shadow' effect that serves as a 'raised button' 3D effect.
The example below is a function call from an image (it's a 32*32 icon for a database, with a question mark) embedded as a shape on a worksheet. I gave this ersatz control button a meaningful name, and I named the macro [Name]_Click(), because I'm replacing the existing 'Click' event procedures.
So this macro is a public subroutine on a worksheet identified with a code name, - users can 'rename' the sheet, changing the user-readable label, but they won't rename the underlying VBA class module - and it's visible as MySheetCodeName.img_TestDefaultDSN_Click() in the 'assign macro' list when you right-click the shape.
..That's why it's Public (not Private, as the automatically-created event procedure stubs for ActiveX controls will be): private subs aren't visible in the 'Assign Macro' list.
Public Sub img_TestDefaultDSN_Click()
ClickDown Me.Shapes("img_TestDefaultDB")
ShowDBStatus "EOD_Reports_DSN"
ClickUp Me.Shapes("img_TestDefaultDB")
End Sub
This calls a pair of generic 'Click Down' and 'Click Up' subroutines, in a regular code module:
Public Function ClickDown(objShape As Excel.Shape)
On Error Resume Next
'Recast the button shadow from bottom-right to top-left:
With objShape.Shadow
.Visible = msoFalse
.OffsetX = -1.2
.OffsetY = -1.2
.Visible = msoTrue
.Blur = 1
.Size = 99
.Transparency = 0.75
.Style = msoShadowStyleInnerShadow
.Obscured = msoFalse
End With
'Darken the button face slightly:
If objShape.Type = msoPicture Then
With objShape.PictureFormat
.Brightness = .Brightness - 0.01
End With
Else
With objShape.Fill
.Visible = msoTrue
.ForeColor.Brightness = .ForeColor.Brightness - 0.01
End With
End If
End Function
Public Function ClickUp(objShape As Excel.Shape)
On Error Resume Next
'Restore the button face to it's default brightness:
With objShape.Shadow
.Visible = msoFalse
.OffsetX = 1.2
.OffsetY = 1.2
.Visible = msoTrue
.Blur = 1
.Size = 99
.Transparency = 0.75
.Style = msoShadowStyleInnerShadow
.Obscured = msoFalse
End With
'Restore the button shadow to bottom-right:
If objShape.Type = msoPicture Then
With objShape.PictureFormat
.Brightness = .Brightness + 0.01
End With
Else
With objShape.Fill
.Visible = msoTrue
.ForeColor.Brightness = .ForeColor.Brightness + 0.01
End With
End If
End Function
You may well have your own preferences for the appearance of a 'control button', but this works for me.
Note that the 'Click Down' effect is never seen if 'Click Up' follows immediately: nor even if a 'Sleep' or an 'Application Wait' statement separates them - you'll only see it if there's real code with a user-detectable elapsed time or a modal dialog.
Is it possible to use Private subs. You only need to change the way you call the subroutines. To call private sub, even located in another code module, you have to use:
Application.Run "[ModuleName.]MacroName"[, arg1] [,arg2...],
Everything is in details explained here:
https://wellsr.com/vba/2015/excel/3-ways-to-call-a-private-sub-from-another-module/

Create a label with VBA and change its name : How can I click it?

I am trying to create labels in a Frame during runtime with VBA. The problem is, I want to be able to click them once they are created. So this is what I made : (my labels are attached to a Frame)
Set TheLabel = Frame.Controls.Add("Forms.Label.1", Visible = True)
With TheLabel
.Name = "Label" & i
.Caption = gTab(i, 2) & "_ " & gTab(i, 0) & Temp
.Left = 6 + gTab(i, 2) * 12
.Top = 12 + 16 * i
.Height = 12
.Width = 200
End With
Where i is an integer (it's the number of the current label).
With this code, I imagine the name of my Label is now Label1, Label2 etc.
But even with this piece of code:
Private Sub Label1_Click()
Frame.Height = 200
End Sub
It doesn't seem to work.
Thanks a lot!
To add controls to a userform at runtime, with code behind the controls, see this answer and this one as well.

Resources