I have a script in VBA that prints out certain user selected variables to a PPT template. In this sub:
Private Sub WarningInfo()
Call Dictionary.WarningInfo
'Sets the font for the warning information text.
With ActiveWindow.Selection.SlideRange.Shapes("WarningText1").TextFrame2.TextRange.Font
.Size = 24
.Name = "Calibri"
.Shadow.Visible = True
End With
ComboBoxList = Array(CStr(ComboBox3))
For Each Ky In ComboBoxList
'On Error Resume Next
'If nothing is selected in ComboBox3, do nothing and exit this sub.
If ComboBox3 = "" Then
Exit Sub
'Otherwise, if it has a selection, insert selected text.
Else
ActiveWindow.Selection.SlideRange.Shapes("WarningText1").TextFrame2.TextRange = vbCrLf & dict2.Item(Ky)(0)
End If
Next
Set dict2 = Nothing
End Sub
It will print out dict2.Item(Ky)(0) within the shape WarningText1. This variable is selected by the user in a GUI and it is pulled from a dictionary. An example of what would be selected and output is "No hail expected".
My next sub is this:
Private Sub WarningInfo2()
Call Dictionary.WindInfo
'Sets the font for the warning information text.
With ActiveWindow.Selection.SlideRange.Shapes("WarningText1").TextFrame2.TextRange.Font
.Size = 24
.Name = "Calibri"
.Shadow.Visible = True
End With
ComboBoxList = Array(CStr(ComboBox4))
For Each Ky In ComboBoxList
'On Error Resume Next
'If nothing is selected in ComboBox4, do nothing and exit this sub.
If ComboBox4 = "" Then
Exit Sub
'Otherwise, if it has a selection, insert selected text.
Else
ActiveWindow.Selection.SlideRange.Shapes("WarningText1").TextFrame2.TextRange = vbCrLf & dict3.Item(Ky)(0)
End If
Next
Set dict3 = Nothing
End Sub
It will print out dict3.Item(Ky)(0). However, with the way this second sub is set up, it will just overwrite the data from the first sub (since both subs are within the same UserForm). I need to find a way to change this line of code ActiveWindow.Selection.SlideRange.Shapes("WarningText1").TextFrame2.TextRange = vbCrLf & dict3.Item(Ky)(0) so that it ADDS this text to the existing text within the shape "WarningText1".
Any ideas?
Thanks!!
ActiveWindow.Selection.SlideRange.Shapes("WarningText1").TextFrame2.TextRange = ActiveWindow.Selection.SlideRange.Shapes("WarningText1").TextFrame2.TextRange & vBCrLf & dict3.Item(Ky) (0)
Related
Need little help from this forum.
I want to replace shape(autoshape) with other autoshape in my project & found a solution here http://www.vbaexpress.com/forum/showthread.php?68760-Change-Fill-color-using-VBA-in-PowerPoint.
But in my project there are some shapes which contains text(I did not use textbox).
The code are select shape(which will be replaced) by some critaria
ie
by height 2. by weidth 3. fill colour 4. by top position.
As textbox is not a autoshape thats why I used shape which contains text & to give text backgroung transparent I used 'shape fill' to 'no fill'.
In my project there are shapes(not contains text) which are same size & same top position(ie the shape just behind the text shape).
Code is working fine for those shape which did not contains text.When I select the text shape & run the code it replaced all the shape behind the text shape ie
not replace the text shape(which I want to replace).
I tried a lot but not getting the solution.I also tried with changeing the weidth of the shape behind the textshape but not get desire result.
Sir any solution will be highly appreaciate.
Option Explicit
Dim oShapeAfterChange As Shape, oShapeToChange As Shape
Dim tShapeAfterChange As MsoAutoShapeType, tShapeToChange As MsoAutoShapeType
Dim iShapeAfterChangeRGB As Long, iShapeAfterChangeHeight As Double, iShapeAfterChangeWidth As Double, iShapeAfterChangeTop As Double
Sub Step1()
If MsgBox("This is Step 1 of a two step process" & vbCrLf & vbCrLf & _
"1. You must already have inserted and selected a new Shape to change to" & vbCrLf & _
"2. After running, Step1 will remember the new type of shape" & vbCrLf & _
"3. Select one of the shapes to be changed" & vbCrLf & _
"4. Run the Step2 Macro", vbOKCancel + vbInformation, "Change Shapes") = vbCancel Then
Exit Sub
End If
Set oShapeAfterChange = Nothing
On Error Resume Next
Set oShapeAfterChange = ActiveWindow.Selection.ShapeRange(1)
oShapeAfterChange.PickUp
tShapeAfterChange = oShapeAfterChange.AutoShapeType
On Error GoTo 0
If oShapeAfterChange Is Nothing Then
Call MsgBox("You must select an AutoShape", vbCritical + vbOKOnly, "Change Shapes")
Exit Sub
End If
Call MsgBox("Destination Shape type memorized", vbOK + vbInformation, "Change Shapes")
End Sub
Sub Step2()
Dim oPres As Presentation
Dim oSlide As Slide
Dim oShape As Shape, oShapeInGroup As Shape
If MsgBox("This is Step 2 of a two step process" & vbCrLf & vbCrLf & _
"1. You must already have selected an instance of a Shape to change" & vbCrLf & _
"2. All instances on all slides of that type of Shape will be changed", vbOKCancel + vbInformation, "Change Shapes") = vbCancel Then
Exit Sub
End If
If oShapeAfterChange Is Nothing Then
Call MsgBox("1. You must select an example of a new Shape to change the shapes to" & vbCrLf & _
"2. Re-run Step1", vbCritical + vbOKOnly, "Change Shapes")
Exit Sub
End If
Set oShapeToChange = Nothing
Set oShapeToChange = ActiveWindow.Selection.ShapeRange(1)
If oShapeToChange.Type = msoGroup Then
If ActiveWindow.Selection.HasChildShapeRange Then
If ActiveWindow.Selection.ChildShapeRange.Count <> 1 Then
Call MsgBox("You must select exactly one Shape within the Group of the type to be changed", vbCritical + vbOKOnly, "Change Shapes")
Exit Sub
Else
Set oShapeToChange = ActiveWindow.Selection.ChildShapeRange(1)
End If
End If
End If
If oShapeToChange Is Nothing Then
Call MsgBox("You must select a Shape of the type to be changed", vbCritical + vbOKOnly, "Change Shapes")
Exit Sub
End If
With oShapeToChange
tShapeToChange = .AutoShapeType
iShapeAfterChangeRGB = .Fill.ForeColor.RGB
iShapeAfterChangeHeight = Round(.Height, 0)
iShapeAfterChangeWidth = Round(.Width, 0)
iShapeAfterChangeTop = Round(.Top, 0)
End With
Set oPres = ActivePresentation
For Each oSlide In oPres.Slides
For Each oShape In oSlide.Shapes
If oShape.Type = msoGroup Then
For Each oShapeInGroup In oShape.GroupItems
Call pvtChangeAutoShapeType(oShapeInGroup)
Next
Else
Call pvtChangeAutoShapeType(oShape)
End If
Next
Next
oShapeAfterChange.Delete
MsgBox "Shapes updated successfully"
End Sub
Private Sub pvtChangeAutoShapeType(o As Shape)
Dim CenterTop As Double, CenterLeft As Double
With o
If .Type <> msoAutoShape Then Exit Sub
If .AutoShapeType <> tShapeToChange Then Exit Sub
If .Fill.ForeColor.RGB <> iShapeAfterChangeRGB Then Exit Sub
If Round(.Height, 0) <> iShapeAfterChangeHeight Then Exit Sub
If Round(.Width, 0) <> iShapeAfterChangeWidth Then Exit Sub
If Round(.Top, 0) <> iShapeAfterChangeTop Then Exit Sub
.AutoShapeType = tShapeAfterChange
CenterTop = .Top + .Height / 2#
CenterLeft = .Left + .Width / 2#
.Height = oShapeAfterChange.Height
.Width = oShapeAfterChange.Width
.Left = CenterLeft - oShapeAfterChange.Width / 2#
.Top = CenterTop - oShapeAfterChange.Height / 2#
.Apply
End With
End Sub
I have the following code which prompts the user to click on a cell value.
Dim sDate As Range
On Error Resume Next
Application.DisplayAlerts = False
Set sDate = Application.InputBox(Prompt:= _
"Please select start date.", _
Title:="Start Date", Type:=8)
On Error GoTo 0
Application.DisplayAlerts = True
If sDate Is Nothing Then
Exit Sub
Else
sDate.Font.Bold = True
End If
End Sub
The input box however once a value is selected lets say for example I click on b3 displays $b$3. I want to display the value that's inside $b$3. For example if 17-Jun was inside $b$3 it should display 17-Jun and not $b$3 in the input box.
Another answer is to use a UserForm.
Create a userform, such as this:
Notes: The "Ok" button is named "Ok", and the white text box is "dateBox"
For the Form Code, use:
Private Sub Ok_Click()
ActiveCell.Font.Bold = True
UserForm1.Hide
End Sub
Then in the Worksheet module, put this:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Cells.Count = 1 Then UserForm1.dateBox.Value = Target.Value
End Sub
Sub bold_Date2()
UserForm1.Show vbModeless
End Sub
Then run the bold_date2():
What I understand that you need to take input from user, and assuming that only single cell will be provided. And you need to retrieve selected cell's value and set it's font style to bold.
You can achieve this by first get selected cell reference, use Font property to set any font styles and read its Value property to get its content.
Set sDate = Application.InputBox(Prompt:= _
"Please select start date.", _
Title:="Start Date", Type:=8)
sDate.Font.Bold = True
MsgBox ("Selected cell's value is: " & sDate.Value)
How does this work for you?
Sub bold_Date()
Dim sDate As Range
On Error Resume Next
Application.DisplayAlerts = False
Set sDate = Application.InputBox(Prompt:="Please select start date.", Title:="Start Date", Type:=8)
If sDate.Cells.Count > 1 Then Set sDate = sDate.Cells(1, 1)
MsgBox ("Date is: " & sDate.Text)
Application.DisplayAlerts = True
If sDate Is Nothing Then
Exit Sub
Else
sDate.Font.Bold = True
End If
End Sub
It will put a messagebox with the date, after selecting a range. Also, it has a check for multiple cells. If multiple cells are selected, it uses the first cell in that range as your new sDate.
I am trying to create a user form in VBA on Microsoft word.
I have been following http://gregmaxey.com/word_tip_pages/create_employ_userform.html
to create the form.
I am very very very new to programming and have basically just been teaching myself as I go.
I get a "compile error: Sub of Function not defined" when I try and step through Call UF
I've attached the whole code for you to look at and tell me where I've gone wrong, happy for any suggestions.
Module - modMain
Option Explicit
Sub Autonew()
Create_Reset_Variables
Call UF
lbl_Exit:
Exit Sub
End Sub
Sub Create_Reset_Variables()
With ActiveDocument.Variables
.Item("varFormNumber").Value = " "
.Item("varTitle").Value = " "
.Item("varGivenName").Value = " "
.Item("varFamilyName").Value = " "
.Item("varStreet").Value = " "
.Item("varSuburb").Value = " "
.Item("varState ").Value = " "
.Item("varPostCode").Value = " "
.Item("varInterviewDate").Value = " "
End With
myUpdateFields
lbl_Exit:
Exit Sub
End Sub
Sub myUpdateFields()
Dim oStyRng As Word.Range
Dim iLink As Long
iLink = ActiveDocument.Sections(1).Headers(1).Range.StoryType
For Each oStyRng In ActiveDocument.StoryRanges
Do
oStyRng.Fields.Update
Set oStyRng = oStyRng.NextStoryRange
Loop Until oStyRng Is Nothing
Next
End Sub
Form - frmLetter13
Option Explicit
Public boolProceed As Boolean
Sub CalUF()
Dim oFrm As frmLetter13
Dim oVars As Word.Variables
Dim strTemp As String
Dim oRng As Word.Range
Dim i As Long
Dim strMultiSel As String
Set oVars = ActiveDocument.Variables
Set oFrm = New frmLetter13
With oFrm
.Show
If .boolProceed Then
oVars("varFormNumber").Value = TextBoxFormNumber
oVars("varTitle").Value = ComboBoxTitle
oVars("varGivenName").Value = TextBoxGivenName
oVars("varFamilyName").Value = TextBoxFamilyName
oVars("varStreet").Value = TextBoxStreet
oVars("varSuburb").Value = TextBoxSuburb
oVars("varState").Value = ComboBoxState
oVars("varPostCode").Value = TextBoxPostCode
oVars("varInterviewDate").Value = TextBoxInterviewDate
End If
Unload oFrm
Set oFrm = Nothing
Set oVars = Nothing
Set oRng = Nothing
lbl_Exit
Exit Sub
End Sub
Private Sub TextBoxFormNumber_Change()
End Sub
Private Sub Userform_Initialize()
With ComboBoxTitle
.AddItem "Mr"
.AddItem "Mrs"
.AddItem "Miss"
.AddItem "Ms"
End With
With ComboBoxState
.AddItem "QLD"
.AddItem "NSW"
.AddItem "ACT"
.AddItem "VIC"
.AddItem "TAS"
.AddItem "SA"
.AddItem "WA"
.AddItem "NT"
End With
lbl_Exit:
Exit Sub
End Sub
Private Sub CommandButtonCancel_Click()
Me.Hide
End Sub
Private Sub CommandButtonClear_Click()
Me.Hide
End Sub
Private Sub CommandButtonOk_Click()
Select Case ""
Case Me.TextBoxFormNumber
MsgBox "Please enter the form number."
Me.TextBoxFormNumber.SetFocus
Exit Sub
Case Me.ComboBoxTitle
MsgBox "Please enter the Applicant's title."
Me.ComboBoxTitle.SetFocus
Exit Sub
Case Me.TextBoxGivenName
MsgBox "Please enter the Applicant's given name."
Me.TextBoxGivenName.SetFocus
Exit Sub
Case Me.TextBoxFamilyName
MsgBox "Please enter the Applicant's family name."
Me.TextBoxFamilyName.SetFocus
Exit Sub
Case Me.TextBoxStreet
MsgBox "Please enter the street address."
Me.TextBoxStreet.SetFocus
Exit Sub
Case Me.TextBoxSuburb
MsgBox "Please enter the suburb."
Me.TextBoxSuburb.SetFocus
Exit Sub
Case Me.ComboBoxState
MsgBox "Please enter the state."
Me.ComboBoxState.SetFocus
Exit Sub
Case Me.TextBoxPostCode
MsgBox "Please enter the postcode."
Me.TextBoxPostCode.SetFocus
Exit Sub
Case Me.TextBoxInterviewDate
MsgBox "Please enter the interview date."
Me.TextBoxInterviewDate.SetFocus
Exit Sub
End Select
'Set value of a public variable declared at the form level.'
Me.boolProceed = True
Me.Hide
lbl_Exit:
Exit Sub
End Sub
There are a couple of issues here.
The first issue is that you do not have a routine named UF for Call UF to call.
The routine that you have named CalUF should not be in the code for the UserForm but should be in modMain and renamed CallUF.
There is no need to include an exit point in your routine as you don't have an error handler.
Your AutoNew routine could be rewritten as:
Sub Autonew()
Create_Reset_Variables
CallUF
End Sub
I have commented your sub myUpdateFields for you.
Sub myUpdateFields()
Dim oStyRng As Word.Range
Dim iLink As Long
iLink = ActiveDocument.Sections(1).Headers(1).Range.StoryType
' logically, iLink should be the StoryType of the first header in Section 1
' Why would this be needed in all StoryRanges?
' Anyway, it is never used. Why have it, then?
' This loops through all the StoryRanges
For Each oStyRng In ActiveDocument.StoryRanges
' This also loops through all the StoryRanges
Do
oStyRng.Fields.Update
Set oStyRng = oStyRng.NextStoryRange
Loop Until oStyRng Is Nothing
'And after you have looped through all the StoryRanges
' Here you go back and start all over again.
Next oStyRng End Sub
Frankly, I don't know if the Do loop does anything here. Perhaps it does. Read up about the NextStoryRange property here. I also don't know if using the same object variable in the inside loop upsets the outside loop. I don't know these things because I never needed to know them. Therefore I wonder why you need them on your second day in school.
You are setting a number of document variables. These could be linked to REF fields in your document which you wish to update. I bet your document has only one section, no footnotes and no textboxes with fields in them. Therefore I think that the following code should do all you need, if not more.
Sub myUpdateFields2()
Dim Rng As Word.Range
For Each Rng In ActiveDocument.StoryRanges
Rng.Fields.Update
Next Rng
End Sub
To you, the huge advantage of this code is that you fully understand it. Towards this end I have avoiding using a name like oStyRng (presumably meant to mean "StoryRange Object"). It is true that a Word.Range is an object. It is also true that the procedure assigns a StoryRange type of Range to this variable. But the over-riding truth is that it is a Word.Range and therefore a Range. Code will be easier to read when you call a spade a spade, and not "metal object for digging earth". My preferred variable name for a Word.Range is, therefore, "Rng". But - just saying. By all means, use names for your variables which make reading your code easy for yourself.
Hi I'm pretty new at the vba so please don't shoot my code :-).
I have a set of repaeting code's. I woukld like to simplify this code by using the code name with an increasing number. I can't get it to run. Can someone help me a bit on the road to get this going.
Below what I'm trying.
The second block is a part of the code now (it's 40 blocks of the same code only increasing the number)
Sub sheet41()
Dim i As Integer
Dim chkname As Integer
chkname = "SheetCheckBox" & i
i = 1
Do
i = i + 1
If chkname.Visible = False Then Exit Sub
If chkname.value = True Then
Sheets("Item_" & i).Select
Call Finalize
End If
Loop Until i = ThisWorkbook.Worksheets.Count
End Sub
This is the old code:
Sub Sheet1()
If SheetCheckBox1.Visible = False Then Exit Sub
If SheetCheckBox1.value = True Then
Sheets("Item_1").Select
Call Finalize
End If
End Sub
Sub Sheet2()
If SheetCheckBox2.Visible = False Then Exit Sub
If SheetCheckBox2.value = True Then
Sheets("Item_2").Select
Call Finalize
End If
End Sub
Sub Sheet3()
If SheetCheckBox3.Visible = False Then Exit Sub
If SheetCheckBox3.value = True Then
Sheets("Item_3").Select
Call Finalize
End If
End Sub
As you can see this should be possible to clean I asume.
This should do it. If finalize isn't called on a worksheet then the reason why is printed to the Immediate Window.
Sub ProcessWorkSheets()
Dim check As MSForms.CHECKBOX
Dim i As Integer
For i = 1 To Worksheets.Count
On Error Resume Next
Set check = Worksheets(i).OLEObjects("SheetCheckBox" & i).Object
On Error GoTo 0
If check Is Nothing Then
Debug.Print Worksheets(i).Name; " - Checkbox not found"
Else
If check.Visible And check.Value Then
Worksheets(i).Select
Call Finalize
Else
Debug.Print Worksheets(i).Name; " - Checkbox", "Visible", check.Visible, "Value:", check.Value
End If
End If
Set check = Nothing
Next
End Sub
If the checkboxes on the Sheet are ActiveX Controls, you can use this to access the checkboxes:
Sheets("sheet1").OLEObjects("chkTest").Object
if you want to change the value of a checkbox, use it like this:
Sheets("sheet1").OLEObjects("chkTest").Object.Value = True
now replace "sheet1" with your actual sheet name and change the "chkTest" to your string chkname
So your complete code should be like this:
Dim i As Integer
Dim sheetname As String
Dim chkname As String
sheetname = "YOUR SHEETNAME HERE"
For i = 1 To ThisWorkbook.Worksheets.Count Step 1
chkname = "SheetCheckBox" & i
If Sheets(sheetname).OLEObjects(chkname).Object.Visible = False Then Exit Sub
If Sheets(sheetname).OLEObjects(chkname).Object.Value = True Then
Sheets("Item_" & i).Select
Call Finalize
End If
Next i
I am very new to VBA and just learning. Here's my situation and problem:
1) I created a working userform with text and comboboxes linking to bookmarks
2) Problem is that it doesn't work if some bookmarks don't exist (and the project will require this: the form will need to run on documents where not all bookmarks are present)
3) I would like the form stop giving me error messages if bookmarks arent there and just fill out the ones that are existing in that particular ocument
4) Here's the Code:
Private Sub cmdOK_Click()
Application.ScreenUpdating = False
With ActiveDocument
If .Bookmarks.Exists("cboYourName") Then
.Range.Text = cboYourName.Value
Else: GoTo 28
End If
If .Bookmarks.Exists("cboYourPhone") Then
.Range.Text = cboYourPhone.Value
Else: GoTo 32
End If
If .Bookmarks.Exists("cboYourFax") Then
.Range.Text = cboYourFax.Value
Else: GoTo 36
End If
If .Bookmarks.Exists("cboYourEmail") Then
.Range.Text = cboYourEmail.Value
Else: GoTo 40
End If
If .Bookmarks.Exists("txtContractName") Then
.Range.Text = txtContractName.Value
Else: GoTo 44
End If
If .Bookmarks.Exists("txtContractNumber") Then
.Range.Text = txtContractNumber.Value
Else: End
End If
End With
Application.ScreenUpdating = True
Unload Me
End Sub
4) How do I get this to work?????????
I think you're close. First, avoid Goto statements. In your code, it's hard to tell what you mean to do. I think the errors are from the Goto statements. Its parameter is a label, not a line number. Second, avoid using End. It's better to have a closing routine. That said, the code works with any number of Exists statements.
Private Sub cmdOK_Click()
Application.ScreenUpdating = False
With ActiveDocument
If .Bookmarks.Exists("cboYourName") Then
.Range.Text = "cboYourName text."
Else
Debug.Print "Bookmark exists."
End If
If .Bookmarks.Exists("cboYourPhone") Then
.Range.Text = "cboYourPhone text"
Else
Debug.Print "Bookmark does not exists."
End If
End With
Application.ScreenUpdating = True
Unload Me
End Sub
However, be aware that each found bookmark completely replaces the content of the document, including subsequently found bookmarks. Is that what you mean to do?