Determining the Number of Lines in a Textbox in VBA - vba

I have a textbox set up in a GUI where the user can enter information. This string is then spit out in a textbox within a PPT slide. Depending on the number of lines used in the textbox within the PPT slide, I need to enter the next set of information so many new lines below the text from the textbox. Here is what I have so far:
This is the code that takes the text the user enters in the textbox within the GUI and places it in the textbox within the PPT slide:
Private Sub Location()
With ActiveWindow.Selection.SlideRange.Shapes("WarningData").TextFrame2
'Make sure there is text in the call to action textbox. If not, display an error message.
If C2AText = "" Then
MsgBox "Woah there! You need to enter text in the location/call to action box."
'Otherwise, if text is inserted, place that text in the WarningData box found on the PPT slide.
Else
.TextRange = C2AText
.TextRange.Paragraphs.Font.Size = 21
.TextRange.Paragraphs.Font.Name = "Calibri"
.TextRange.Paragraphs.Font.Shadow.Visible = True
.TextRange.Paragraphs.Font.Bold = msoTrue
End If
End With
End Sub
This text determines whether or not anything is selected in the HailInfo drop down. If it is, I need to place this text so many lines below the C2AText that was inserted in the previous Sub:
Private Sub HailInfo()
Call Dictionary.HailInfo
ComboBoxList = Array(CStr(HailDropDown))
For Each Ky In ComboBoxList
'On Error Resume Next
With ActiveWindow.Selection.SlideRange.Shapes("WarningData").TextFrame2
'If nothing is selected in HailDropDown, do nothing and exit this sub.
If HailDropDown = "" Then
Exit Sub
'If a hail option is selected, execute the following code.
ElseIf HailDropDown <> "" And C2AText.LineCount = 2 Then
.TextRange = .TextRange & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & dict2.Item(Ky)(0)
ElseIf HailDropDown <> "" And C2AText.LineCount = 3 Then
.TextRange = .TextRange & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & dict2.Item(Ky)(0)
End If
End With
Next
Set dict2 = Nothing
End Sub
Using the C2AText.LineCount within the HailInfo sub does not appear to do anything. It will not insert the hail text anywhere, so I am not sure what I am doing wrong. Any help would be greatly appreciated...thanks!!

You should try the following ...
Private Sub HailInfo()
Call Dictionary.HailInfo
ComboBoxList = Array(CStr(HailDropDown))
For Each Ky In ComboBoxList
'On Error Resume Next
With ActiveWindow.Selection.SlideRange.Shapes("WarningData").TextFrame2
'If nothing is selected in HailDropDown, do nothing and exit this sub.
If HailDropDown = "" Then
Exit Sub
'If a hail option is selected, execute the following code.
Else
.TextRange.Text = .TextRange.Text & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & dict2.Item(Ky)(0)
End If
End With
Next
Set dict2 = Nothing
End Sub
You were only referencing .TextRange, rather than .TextRange.Text.
Also, because you need to add the text at the end, you only need an Else condition, rather than two ElseIfs that both do the same thing! ;0)
More example code ... https://msdn.microsoft.com/en-us/library/office/ff822136.aspx

Related

Search box not allowing me to type a space between words

I have a textbox on a form that is filtering my data by the company name. The reason for the close and open code in the error handling is because I couldn't find a way to easily fix it throwing an error when a combination of characters not present would be entered. This way it just closes and reopens it and basically resets it. I am still fairly new to this development and all I know is taught to myself through google and forums like this so forgive my lack of understanding when things should make sense to someone else able to do these types of functions.
Upon typing part of a company name and pressing space to type in a second word it essentially removes the space and puts the cursor back to the last letter typed.
This is the code for the textbox.
Reminder that I find solutions to the functions I need and adapt the code as best I can to suit my needs. I don't pretend to fully comprehend what I use yet and I'm still learning.
Private Sub txtSearch_KeyUp(KeyCode As Integer, Shift As Integer)
On Error GoTo errHandler
Dim filterText As String
'Apply or update filter based on user input.
If Len(txtSearch.Text) > 0 Then
filterText = txtSearch.Text
Me.Form.Filter = "[tblSuppliers]![SupplierName] like '*" & filterText & "*'"
Me.FilterOn = True
'Retain filter text in search box after refresh
txtSearch.Text = filterText
txtSearch.SelStart = Len(txtSearch.Text)
Else
'Remove filter
Me.Filter = ""
Me.FilterOn = False
txtSearch.SetFocus
End If
Exit Sub
errHandler:
MsgBox Err.Number & " - " & Err.Description, vbInformation + vbOKOnly, "Information"
DoCmd.Close acForm, "frmCosteeDetails", acSaveNo
DoCmd.OpenForm "frmCosteeDetails"
End Sub
In my search to try and find a way to fix the removal of spaces I found this function that someone listed but wasn't sure how to integrate it into my code.
Public Function FindWord(varFindIn As Variant, varWord As Variant) As Boolean
Const PUNCLIST = """' .,?!:;(){}[]/"
Dim intPos As Integer
FindWord = False
If Not IsNull(varFindIn) And Not IsNull(varWord) Then
intPos = InStr(varFindIn, varWord)
' loop until no instances of sought substring found
Do While intPos > 0
' is it at start of string
If intPos = 1 Then
' is it whole string?
If Len(varFindIn) = Len(varWord) Then
FindWord = True
Exit Function
' is it followed by a space or punctuation mark?
ElseIf InStr(PUNCLIST, Mid(varFindIn, intPos + Len(varWord), 1)) > 0 Then
FindWord = True
Exit Function
End If
Else
' is it precedeed by a space or punctuation mark?
If InStr(PUNCLIST, Mid(varFindIn, intPos - 1, 1)) > 0 Then
' is it at end of string or followed by a space or punctuation mark?
If InStr(PUNCLIST, Mid(varFindIn, intPos + Len(varWord), 1)) > 0 Then
FindWord = True
Exit Function
End If
End If
End If
' remove characters up to end of first instance
' of sought substring before looping
varFindIn = Mid(varFindIn, intPos + 1)
intPos = InStr(varFindIn, varWord)
Loop
End If
End Function
Edit - Code for Current Solution
Private Sub txtSearch_Change()
On Error GoTo errHandler
'clear filter
If Len(txtSearch.Text) = 0 Then
FilterOn = False
Filter = vbNullString
Exit Sub
End If
'apply filter
Filter = "[SupplierName] like '*" & txtSearch.Text & "*'"
FilterOn = True
Leave:
Exit Sub
errHandler:
MsgBox Err.Number & " - " & Err.Description, vbInformation + vbOKOnly, "Information"
Resume Leave
'DoCmd.Close acForm, "frmCosteeDetails", acSaveNo
'DoCmd.OpenForm "frmCosteeDetails"
End Sub
A simple filter method is as shown below. You will need to handle the Change() event and use the Text property which is populated on every keystroke.
Also, filtering does not requery data, so no need to try to manually retain the search value.
The below assumes the txtSearch and the data due to be filtered are on the same form. If that's not the case, the reference to the data-form will need to be changed.
Private Sub txtSearch_Change()
On Error GoTo errHandler
'clear filter
If Len(txtSearch.Text) = 0 Then
FilterOn = False
Filter = vbNullString
Exit Sub
End If
'apply filter
Filter = "[SupplierName] like '*" & txtSearch.Text & "*'"
FilterOn = True
Leave:
Exit Sub
errHandler:
MsgBox Err.Number & " - " & Err.Description, vbInformation + vbOKOnly, "Information"
Resume Leave
End Sub
Rather than using a text box to constantly update as typed just change it to a search button that when clicked searches based on the value in the search box. All you have to do is then update the search criteria each time and click search. a bit slower but functions mostly the same.
Private Sub cmdSearch_Click()
Dim strWhere As String
strWhere = "[tblSuppliers]![SupplierName] Like '*" & Me.txtSearch & "*'"
'Apply Filter
Me.Filter = strWhere
Me.FilterOn = True
End Sub

VBA message box with a list of failed checks

how do i create a message box that shows all of the mandatory fields that have not been filled in.
I am using a table that has an auto filter on it ("Table11") to show only the checks that have failed.
I want to translate these into a message box that show when a sales agent tries to create the contract.
Table layout below:
The below sample goes through Table11 and creates a list of all those with marked with 'Check', Then displays a message if there were items.
Public Sub Sample()
Dim LngCounter As Long
Dim Tbl As Excel.Range
Dim StrMsg As String
Set Tbl = ThisWorkbook.Worksheets("Sheet1").Range("Table11")
For LngCounter = 2 To Tbl.Rows.Count
If Trim(UCase(Tbl.Cells(LngCounter, 2))) = "CHECK" Then
StrMsg = StrMsg & Tbl.Cells(LngCounter, 1) & vbNewLine
End If
Next
Set Tbl = Nothing
If StrMsg <> "" Then
MsgBox "The following items need attention before continuing: - " & vbNewLine & vbNewLine & StrMsg, vbOKOnly + vbExclamation, "Data Validation"
End If
End Sub
This assumes CHECK means there's a problem
Sub ErrorMessage()
Dim strErrMsg As String
Dim cell As Range
If Application.CountIf(-yourfilteredrangehere-), "CHECK") = 0 Then Exit Sub
'no problems to output
For Each cell In Range(-yourfilteredrangehere-)
'next line assumes checkitem in previous column, change if not
If cell = "check" Then strErrMsg = strErrMsg & "Please check " & cell.Offset(0, -1) & vbCrLf
Next cell
MsgBox strErrMsg
End Sub

Excel VBA & VB6 Printer

I have the following code, this code was written in VB6 but i can not open the form or check any references.
Private Sub PopulatePrinterCombo(cmbDestination As ComboBox)
Dim objPrinter As Printer 'a printer in the Printers collection object
'Add the printers to the combo box
For Each objPrinter In printers
cmbPrinter.AddItem objPrinter.DeviceName
Next
'Set current selection to the default printer
cmbDestination.Text = Printer.DeviceName
End Sub
I am currently copying the code onto Excel VBA macro, the problem is the Dim objPrinter As Printer code, i keep getting an error message saying "USER DEFINED TYPE NOT DEFINED", do i need a reference to add on VBA to be able to get the option of declaring a variable as a "Printer" or something?
My second question is that i do not fully understand the "Printers" in the line For Each objPrinter In printers, what is "Printers"? can someone please explain that to me.
Thank you
PART 2
I am now trying to print files, i have the following as my code:
'Initialize values
intDraftsPrinted = 0
If objDraftPaths.Count > 1 Then
Else
intSelectedDraftCount = CountSelectedDrafts
End If
'prompt user to make sure
intMsgBoxResponse = MsgBox("You selected " & intSelectedDraftCount & " part numbers. After removing duplicates" & vbNewLine & "there were " & objDraftPaths.Count & " unique draft files found." & vbNewLine & "Do you want to print these files?", vbYesNo, "TD Printer")
If intMsgBoxResponse <> vbYes Then
intSelectedDraftCount = 0 'So the following for loop will not entered
Else
intSelectedDraftCount = objDraftPaths.Count
End If
For i = 1 To intSelectedDraftCount
booSuccess = False
'open the draft file
Set objDraftDocument = OpenSolidEdgeDraft(objDraftPaths.Item(i))
If objDraftDocument Is Nothing Then
'could not open file
MsgBox "Could not open the following draft file:" & vbNewLine & _
objDraftPaths.Item(i), vbExclamation, "Solid Edge Error"
Else
'Print the draft file
For Each objSheet In objDraftDocument.Sheets
strSheetSize = DetermineSheetSize(objSheet)
If strSheetSize <> "" Then
'Determine orientation
If InStr(1, strSheetSize, "90") <> 0 Then
'Print as landscape
intOrientation = vbPRORLandscape
Else
'Print as portrait
intOrientation = vbPRORPortrait
End If
'Specify Sheet Size
Select Case Left(strSheetSize, 1)
Case "A"
intPaperSize = VBRUN.PrinterObjectConstants.vbPRPSLetter
Case "B"
intPaperSize = VBRUN.PrinterObjectConstants.vbPRPS11x17
Case "C"
intPaperSize = VBRUN.PrinterObjectConstants.vbPRPSCSheet
Case "D"
intPaperSize = VBRUN.PrinterObjectConstants.vbPRPSDSheet
Case "E"
intPaperSize = VBRUN.PrinterObjectConstants.vbPRPSESheet
Case Else
intPaperSize = VBRUN.PrinterObjectConstants.vbPRPSLetter
End Select
'Enable error handling
On Error Resume Next
'Activate the current sheet
objSheet.Activate
If Err Then
'Could not activate sheet
MsgBox "An error occurred while attempting to print: " & vbNewLine & objDraftPaths.Item(i) & vbNewLine & "The error was:" & vbNewLine & "Error Number: " & Err.Number & vbNewLine & "Error Description: " & Err.Description, vbExclamation, "Solid Edge Error"
Err.Clear
Else
'Print to the printer specified by the combo box
objDraftDocument.PrintOut cmbPrinter.Text, 1, intOrientation, intPaperSize, , , , igPrintSelected
If Err Then
'Could not print document
MsgBox "An error occurred while attempting to print: " & vbNewLine & objDraftPaths.Item(i) & vbNewLine & "The error was:" & vbNewLine & "Error Number: " & Err.Number & vbNewLine & "Error Description: " & Err.Description, vbExclamation, "Solid Edge Error"
Err.Clear
Else
booSuccess = True
End If
End If
'Disable error handling
On Error GoTo 0
End If
Next
'Close the file
objDraftDocument.Close False
intDraftsPrinted = intDraftsPrinted + 1
End If
Next i
'Dereference objects
Set objSheet = Nothing
Set objDraftDocument = Nothing
'Set objDraftPaths = Nothing
PrintSelectedDrafts = intDraftsPrinted
Now the problem comes when i hits the line that says: intOrientation = vbPRORLandscape
in excel VBA, it does not recognize "vbPRORLandscape" as well as the next line "vbPRORPortrait". Is there a way to fix that?
Also, i have a feeling that VBRUN.PrinterObjectConstants.vbPRPSLetter and the rest of those lines might not work out as well. It works in VB6 though.
Thank you
It appears the Printers Collection is available in the MS Access VBA environment but I do not believe it is intrinsic to the Excel VBA environment.
I use the WshNetwork object of Windows Script Host to list the available printers. I use the subroutine below to populate a ComboBox with the list of printers that are connected to the system. In order for this code to work you will need to add the "Windows Script Host Object Model" reference to your VBA project. (Menu: Tools > References [Select from list])
I added the (j) loop to alphabetize the list.
Sub populatePrintersList()
Dim nwo As New WshNetwork
Dim i As Integer
Dim j As Integer
Dim bAdd As Boolean
bAdd = True
cmbPrinter.Clear
For i = 0 To (nwo.EnumPrinterConnections.Count / 2) - 1
For j = 0 To cmbPrinter.ListCount - 1
If nwo.EnumPrinterConnections(i * 2 + 1) < cmbPrinter.List(j) Then
cmbPrinter.AddItem nwo.EnumPrinterConnections(i * 2 + 1), j
bAdd = False
Exit For
End If
Next j
If bAdd Then cmbPrinter.AddItem nwo.EnumPrinterConnections(i * 2 + 1): bAdd = True
Next i
cmbPrinter.ListIndex = 0
End Sub
Part 2:
MSDN contains reference material for the Worksheet.PrintOut method: Worksheet.PrintOut
In depth documentation for the methods and properties of the Worksheet.PageSetup object can also be found on MSDN: Worksheet.PageSetup
I suggest using these resources to find a plethora of answers.

iterate through If statment checking checkboxs in vba word

I have a code that works to check singel checkbox
Sub check_if_checked()
If CheckBox1.Value Then
MsgBox "checked"
Else
MsgBox "not checked"
End If
End Sub
What i want to do is to create a loop where in the if statment i can replace the check box number with the loop iteration variable.
Something like
If "CheckBox" & i.Value Then
Can this be done or maybe done a diffrent way?
In the below example I have 4 Check Boxes with the following names CheckBox1, CheckBox2, CheckBox3, CheckBox4.
Sub check_if_checked()
Dim i As Integer
i = 1
Do While i <= 4
If (IsNull(Me("CheckBox" & i).value)) Then _
MsgBox ("CheckBox" & i & " is Null") Else _
MsgBox (Me("CheckBox" & i).value)
i = i + 1
Loop
End Sub
Or the following may work for you:
Sub check_if_checked()
Dim TempCntrl As Control
For Each TempCntrl In UserForm1.Controls
If TempCntrl.Name Like "CheckBox*" Then
MsgBox (TempCntrl.Name & ": " & TempCntrl.value)
End If
Next
End Sub

adding multiple messgeboxes values to single messagebox in vba

I have this code with me where i can display the message when every outer loop ends. I want to catch all these messages in suppose array or soome list like structure and then at the end want to display each of these messages into one msgbox. Would appreciate if someone could help me.
Thanks.
For Each objNavFolder In objNavGroup.NavigationFolders
SkippedItemCounter = 0
If oItems.Count = 0 Then
MsgBox "No Appointments items in " & objNavFolder.DisplayName & "'s folder"
Else
NextRow = NextRow + 1
For Each MyItem In oItems
If MyItem = "" Then
SkippedItemCounter = SkippedItemCounter + 1
End If
'some code here
Next
Set objExpl = _colExpl.Add(objFolder, olFolderDisplayNormal)
NextRow = NextRow - 1
End If
MsgBox "No. of items= "&SkippedItemCounter&"skipped from"&objNavFolder.DisplayName&""
Next
End If
End If
End If
instead of calling msgboxes, create a String and keep adding the messages - at the end of code msgbox(yourString)
for example
decalare a string before the main sub
Dim yourFinalMessage As String ' or Dim yourFinalMessage$
instead of
MsgBox "No Appointments items in " & objNavFolder.DisplayName & "'s folder"
say
yourFinalMessage = yourFinalMessage & vbCrLf & & _
"No Appointments items in " & objNavFolder.DisplayName & "'s folder"
keep doing this until the loop ends.
at the end of loop say
msgbox YourFinalMessage
Not sure to exactly understand what you want, but you might try to add this to a module:
Option Explicit
Dim globalMsg as String
globalMsg = ""
Function customMsg(msg as String)
MsgBox msg
globalMsg = globalMsg & VbCrLf & msg
End Function
Just call customMsg("Your Message") to display a MsgBox and at the end, call MsgBox globalMsg to display all the messages as a single message (one per line). There are a lot of other ways to do this, it depends on you. Please be more explicit if you want any further help.