I have this code to condense text to 0.2 but would like to have it incremental. So each time I run the code the text condense by 0.2.
Does anyone know what I need to add to my code?
Sub CondenseText()
On Error GoTo Catch
Dim o As Shape, b As Boolean
Set o = ActiveWindow.Selection.ShapeRange(1)
If Not o Is Nothing Then
With o
.TextFrame2.TextRange.Font.Spacing = -0.2
End With
End If
Exit Sub
Catch:
If Err.Number = -2147188160 Then MsgBox CG_NOTHING_SELECTED
End Sub
Related
I'm trying to change text in a SmartArt. Specifically this type:
I can replicate the Minimum Working Example below on two machines.
This code enters the .HasText = msoTrue branch even though the debugger says that .HasText = 0. This causes shi.TextFrame.TextRange.Text to fail.
Sub enumerate_subshapes(shi As Shape, Optional depth As Integer = 0)
'If True Then
If shi.HasTextFrame Then
If shi.TextFrame.HasText Then
Debug.Print depth & " YES: ", shi.Type, shi.HasTextFrame, shi.TextFrame.HasText, shi.TextFrame.TextRange.Text
Else
Debug.Print depth & " NO: ", shi.Type, shi.HasTextFrame, shi.TextFrame.HasText
End If
End If
Select Case shi.Type
Case msoSmartArt
For i = 1 To shi.GroupItems.Count
enumerate_subshapes shi.GroupItems.Item(i), depth + 1
Next i
End Select
End Sub
Sub vba_bug_mwe()
Dim shi As Shape
For Each shi In ActivePresentation.Slides(1).Shapes
Debug.Print "############### " & shi.Name
enumerate_subshapes shi
Next
End Sub
If you uncomment the If true then line and comment the If shi.HasTextFrame Then line, then you get the expected result, i.e., the inner test works correctly.
It looks like a bug to me, TBH, in which case it doesn't really belong here. But maybe there is some VBA subtlety I'm missing.
A piece of SmartArt is a nested group of shapes. You need to drill down to individual subshapes to get any useful information. You haven't stated your overall goal with this, but here's how to get the text from each node:
Sub GetSmartArtNodeText()
Dim oShape As Shape
Dim oNode As SmartArtNode
For Each oShape In ActivePresentation.Slides(1).Shapes
If oShape.HasSmartArt = True Then
For Each oNode In oShape.SmartArt.Nodes
MsgBox oNode.TextFrame2.TextRange.Text
Next oNode
End If
Next oShape
End Sub
Sub fixdsd()
For q = 1 To 20
If ActivePresentation.Slides(40).Shapes(q).Name = "Wrong" Then
With ActivePresentation.Slides(40) _
.Shapes(q).ActionSettings(ppMouseClick)
.Action = ppActionRun
.Run = "Answer"
.AnimateAction = True
End With
On Error Resume Next
Next q
End If
End Sub
I'm getting a compile error: Next without For.
Can someone please point out how to correct it?
this is going to be easy for any VBA expert out there so, apologies for the novice question! I have a code to condense text into a text box. At the moment the code condensed all the text inside the text box but I want the code to work for selected text only. How can I modify this code to make it work?
Many thanks on advance!
PJ
Sub CondenseText()
On Error GoTo Catch
Dim o As Shape, b As Boolean
Set o = ActiveWindow.Selection.ShapeRange(1)
If Not o Is Nothing Then
With o
.TextFrame2.TextRange.Font.Spacing = .TextFrame2.TextRange.Font.Spacing - 0.1
End With
End If
Exit Sub
Catch:
If Err.Number = -2147188160 Then MsgBox CG_NOTHING_SELECTED
End Sub
Sub CondenseText()
Dim oTextRange2 As TextRange2
' You can check Selection.Type rather than relying
' on an errorhandler if you like
If ActiveWindow.Selection.Type = ppSelectionText Then
Set oTextRange2 = ActiveWindow.Selection.TextRange2
If Not oTextRange2 Is Nothing Then
oTextRange2.Font.Spacing = oTextRange2.Font.Spacing - 0.1
End If
' and you could add an Else clause with msg for the
' user here if you like:
Else
MsgBox "Yo! Select some text first, OK?"
End If
End Sub
i can not figure this out below is the code.... I hit the error for the 2nd case to open the form frmBookingLCL.show the form name is correct. I can't figure this out. the line with the **** us the error line. HELP!!
Public Sub SendBookingEmail()
StartTime = Timer
With Session
'check first 2 letters of shipper's code, if not US raise error
If IsStartPositionCorrect(5, 14, 2, "US") <> True Or IsStartPositionCorrect(5, 2, 8, "Customer") <> True And GetDisplayText(4, 20, 1) <> "0" Then
If MsgBox("You don't appear to be in Logis ocean export US file. Please enter the file first and then run the macro.", vbOKOnly, "Export file verification....") Then
Exit Sub
End If
End If
sTypeOfMessage = "booking"
sShipmentType = Trim(.GetDisplayText(9, 61, 3))
sFileType = Trim(.GetDisplayText(4, 32, 1))
bFullVersion = False
'On Error GoTo ErrHand
'Get Outlook if it's running
Set oOutlookApp = GetObject(, "Outlook.Application")
'collect data fields for the e-mail body
GetAllLogisDataBooking
'Blow up the question form
Select Case sShipmentType
Case "FCL", "CMF", "CCS", "FPR"
frmBookingFCL.Show
Case "LCL", "GWY", "CLD"
frmBookingLCL.Show**********ERROR HERE
Case Else
frmBookingFCL.Show
'frmBookingOthers.Show
End Select
End With
Finish = Timer
TimeTook = Finish - StartTime
MyMacroStats = GetProcedureStats("Booking Confirmation", TimeTook)
Exit Sub
ErrHand:
If Err = 429 Then
MsgBox "Please note you must start Microsoft Outlook first."
End
End If
End Sub
Most likely, the error is in your user form. See the code comments.
I tried to replicate the issue below:
Sub test()
'/Sub to load the user form.
Dim x As String
x = "a"
Select Case x
Case "a", "b", "c"
UserForm1.Show '/ It Will error-out here during debugging.
End Select
End Sub
Code in UserForm1
Private Sub UserForm_Initialize()
'/ Code from : https://msdn.microsoft.com/en-us/library/office/gg251554.aspx
'/ Actually the error happens here.
Dim RetVal ' Implicitly a Variant.
' Default property is assigned to Type 8 Variant RetVal.
RetVal = CreateObject("Excel.Application")
RetVal.Visible = True ' Error occurs here.
End Sub
So going by your intialize code, either you are missing or have incorrect name for one of these controls.
frTrucker,CheckBox1,txtPickupDate. Once you correct them, the error will be gone.
I am using data validation in excel 2007. I am using this code to make invalid data marked with red circle.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rc As Integer
Range(Target.Address).Select
ActiveSheet.ClearCircles
ActiveSheet.CircleInvalid
If Not Range(Target.Address).Validation.Value Then
rc = MsgBox("Data Validation errors exist! " & Range
(Target.Address).Validation.ErrorMessage & " Please correct circled entries!", vbCritical, "Failure")
Exit Sub
End If
End Sub
As you can see in the code when I put wrong data then first of that specific range is going to selected and then all invalid data is marked with red circle.
But I want that only that specific cell should be marked with red not all data .
Thanks.
You can try this code from an Excel MVP:
Dim TheCircledCell As Range
Sub CircleCells(CellToCircle As Range)
If Not CellToCircle Is Nothing Then
With CellToCircle
If .Count > 1 Then Exit Sub
Set TheCircledCell = CellToCircle
.Validation.Delete
.Validation.Add xlValidateTextLength, xlValidAlertInformation, xlEqual, 2147483647#
.Validation.IgnoreBlank = False
.Parent.CircleInvalid
End With
End If
End Sub
Sub ClearCircles()
If Not TheCircledCell Is Nothing Then
With TheCircledCell
.Validation.Delete
.Parent.ClearCircles
End With
End If
End Sub
Note that you can't use the Excel standard Validation function on these cells.
[Source and explanation of the code]