I am trying to display a form (Progress Bar) on a word document. But keep getting an error: Run-time error 424 Object required when it gets to 'ufProgress.Show'.
Dim j As Long
Dim pctdone As Single
ufProgress.Show
ufProgress.LabelProgress.Width = 0
For j = 1 To intPageCount
pctdone = j / intPageCount
With ufProgress
.LabelCaption.Caption = "Processing Row " & j & " of " & intPageCount
.LabelProgress.Width = pctdone * (.FrameProgress.Width)
End With
Related
I want to give credit to an agent, if they're the one that sent the message, but only if their signature is at the top of the email.
Here is what I have. The search order is off. The code searches for one name at a time, and clear through the document. I need it to search for All names, the first one that hits in the body of the email.
Sub CountOccurences_SpecificText_In_Folder()
Dim MailItem As Outlook.MailItem
Dim strSpecificText As String
Dim tmpStr As String
Dim x As Integer
Dim Count As Integer
Dim HunterCnt As Integer
Dim SunmolaCnt As Integer
Dim RodriguezCnt As Integer
Dim MammedatyCnt As Integer
Dim MitchellCnt As Integer
Dim TannerCnt As Integer
Dim TAYLORCnt As Integer
Dim WilsonCnt As Integer
Dim WilliamsCnt As Integer
Dim GrooverCnt As Integer
Dim TyreeCnt As Integer
Dim ChapmanCnt As Integer
Dim LukerCnt As Integer
Dim KlinedinstCnt As Integer
Dim HicksCnt As Integer
Dim NATHANIALCnt As Integer
Dim SkinnerCnt As Integer
Dim SimonsCnt As Integer
Dim AgentNames(14) As Variant
AgentNames(0) = "Simons"
AgentNames(1) = "Skinner"
AgentNames(2) = "Mammedaty"
AgentNames(3) = "Hunter"
AgentNames(4) = "Sunmola"
AgentNames(5) = "Rodriguez"
AgentNames(6) = "Mitchell"
AgentNames(7) = "Tanner"
AgentNames(8) = "Taylor"
AgentNames(9) = "Wilson"
AgentNames(10) = "Williams"
AgentNames(11) = "Groover"
AgentNames(12) = "Tyree"
AgentNames(13) = "Chapman"
AgentNames(14) = "Luker"
x = 0
While x < ActiveExplorer.Selection.Count
x = x + 1
Set MailItem = ActiveExplorer.Selection.item(x)
tmpStr = MailItem.Body
For Each Agent In AgentNames
If InStr(tmpStr, Agent) <> 0 Then
If Agent = "Assunta" Then
HunterCnt = HunterCnt + 1
GoTo skip
End If
If Agent = "Sunmola" Then
SunmolaCnt = SunmolaCnt + 1
GoTo skip
End If
If Agent = "Rodriguez" Then
RodriguezCnt = RodriguezCnt + 1
GoTo skip
End If
If Agent = "Mammedaty" Then
MammedatyCnt = MammedatyCnt + 1
GoTo skip
End If
If Agent = "Mitchell" Then
MitchellCnt = MitchellCnt + 1
GoTo skip
End If
If Agent = "Tanner" Then
TannerCnt = TannerCnt + 1
GoTo skip
End If
If Agent = "Taylor" Then
TAYLORCnt = TAYLORCnt + 1
GoTo skip
End If
If Agent = "Wilson" Then
WilsonCnt = WilsonCnt + 1
GoTo skip
End If
If Agent = "Williams" Then
WilliamsCnt = WilliamsCnt + 1
GoTo skip
End If
If Agent = "Groover" Then
GrooverCnt = GrooverCnt + 1
GoTo skip
End If
If Agent = "Tyree" Then
TyreeCnt = TyreeCnt + 1
GoTo skip
End If
If Agent = "Chapman" Then
ChapmanCnt = ChapmanCnt + 1
GoTo skip
End If
If Agent = "Luker" Then
LukerCnt = LukerCnt + 1
GoTo skip
End If
If Agent = "Hicks" Then
HicksCnt = HicksCnt + 1
GoTo skip
End If
End If
Next
skip:
Count = Count + 1
Wend
MsgBox "Found " & vbCrLf & "Hunter Count: " & HunterCnt & vbCrLf & "Sunmola Count: " & SunmolaCnt & vbCrLf & "Rodriguez Count: " & RodriguezCnt & vbCrLf & "Mammedaty Count: " & MammedatyCnt & vbCrLf & "Mitchell Count: " & MitchellCnt & vbCrLf & "Tanner Count: " & TannerCnt & vbCrLf & "Taylor Count: " & TAYLORCnt & vbCrLf & "Wilson Count: " & WilsonCnt & vbCrLf & "Williams Count: " & WilliamsCnt & vbCrLf & "Groover Count: " & GrooverCnt & vbCrLf & "Tyree Count: " & TyreeCnt & vbCrLf & "Chapman Count: " & ChapmanCnt & vbCrLf & "Luker Count: " & LukerCnt & vbCrLf & " in: " & Count & " emails"
End Sub
InStr returns positional information. While it is difficult to find the first occurrence of an array member within the text (you would need to build and compare matches), you can find the first position of each name then find which came first.
For example (untested)
Sub CountOccurences_SpecificText_In_Folder()
Dim MailItem As Outlook.MailItem
Dim i As Long, x As Long, position As Long, First As Long
Dim AgentNames() As String
AgentNames = Split("Simons,Skinner,Mammedaty,Hunter,Sunmola,Rodriguez,Mitchell,Tanner,Taylor,Wilson,Williams,Groover,Tyree,Chapman,Luker", ",")
Dim AgentCount(LBound(AgentNames) To UBound(AgentNames)) As Long
For i = LBound(AgentCount) To UBound(AgentCount)
AgentCount(i) = 0
Next i
For Each MailItem In ActiveExplorer.Selection
x = 0
For i = LBound(AgentNames) To UBound(AgentNames)
position = InStr(MailItem.Body, AgentNames(i))
If x > 0 Then
If position < x Then
x = position
First = i
End If
Else
If position > 0 Then
x = position
First = i
End If
End If
Next i
AgentCount(First) = AgentCount(First) + 1
Next MailItem
For i = LBound(AgentNames) To UBound(AgentNames)
Debug.Print AgentNames(i) & " Count: " & AgentCount(i)
Next i
End Sub
The idea in the previous answer may be better implemented like this:
Option Explicit
Sub CountOccurences_SpecificText_SelectedItems()
Dim objItem As Object
Dim objMail As MailItem
Dim i As Long
Dim j As Long
Dim x As Long
Dim position As Long
Dim First As Long
Dim AgentNames() As String
AgentNames = Split("Simons,Skinner,Mammedaty,Hunter,Sunmola,Rodriguez,Mitchell,Tanner,Taylor,Wilson,Williams,Groover,Tyree,Chapman,Luker", ",")
ReDim AgentCount(LBound(AgentNames) To UBound(AgentNames)) As Long
For j = 1 To ActiveExplorer.Selection.Count
Set objItem = ActiveExplorer.Selection(j)
' Verify before attempting to return mailitem poroperties
If TypeOf objItem Is MailItem Then
Set objMail = objItem
Debug.Print
Debug.Print "objMail.Subject: " & objMail.Subject
x = Len(objMail.Body)
For i = LBound(AgentNames) To UBound(AgentNames)
Debug.Print
Debug.Print "AgentNames(i): " & AgentNames(i)
position = InStr(objMail.Body, AgentNames(i))
Debug.Print " position: " & position
If position > 0 Then
If position < x Then
x = position
First = i
End If
End If
Debug.Print "Lowest position: " & x
Debug.Print " Current first: " & AgentNames(First)
Next i
If x < Len(objMail.Body) Then
AgentCount(First) = AgentCount(First) + 1
Debug.Print
Debug.Print AgentNames(First) & " was found first"
Else
Debug.Print "No agent found."
End If
End If
Next
For i = LBound(AgentNames) To UBound(AgentNames)
Debug.Print AgentNames(i) & " Count: " & AgentCount(i)
Next i
End Sub
I am trying to get the items that I have and initiate all the separate items into its own respective cell.
With Me.selecteditems
For i = 1 To .ListCount - 1
If .Selected(i) Then
found = True
On Error Resume Next
str = ThisWorkbook.Sheets(9).Range("A1:Cells(i, 1)")
quantity = ThisWorkbook.Sheets(9).Range("A1:Cells(i, 2)")
On Error GoTo 0
End If
Next i
End With
This part of the below code, is supposed to put the items that come from the longer part of the code and put in the item, str, and the amount, quantity. I tried different ways and just recently I tried repeating how it was before, it doesn't come out that well. Also without the error it throws me:
Application-defined or Object-defined Error
The Whole Code:
Dim i As Long, j As Long, ii As Long
Dim found As Boolean
Dim str As String
Dim message, title, defaultval As String
Dim quantity As String
With Me.selecteditems
For i = 0 To .ListCount - 1
If .Selected(i) Then
found = True
For ii = 0 To .ColumnCount - 1
If str = "" Then
str = .List(i, ii) & vbTab
Else
If ii < .ColumnCount - 1 Then
str = str & .List(i, ii) & vbTab
Else
str = str & .List(i, ii)
End If
End If
Next ii
message = "How much" & vbCrLf & str & "?"
title = "Amount"
defaultval = "1"
quantity = InputBox(message, title, defaultval)
str = str & " x " & quantity & vbNewLine
End If
Next i
End With
With Me.selecteditems
For i = 1 To .ListCount - 1
If .Selected(i) Then
found = True
On Error Resume Next
str = ThisWorkbook.Sheets(9).Range("A1:Cells(i, 1)")
quantity = ThisWorkbook.Sheets(9).Range("A1:Cells(i, 2)")
On Error GoTo 0
End If
Next i
End With
I have a macro which pass through paragraphs of a word document. This code is intended to pass the paragraph, identify its outline level and retrieve the content when the desired paragraph outline level is found. With this information, I'm populating a listbox that will allow users to choose from what point they want to export some text in a document.
This functionality is working, however, I'm looking for a way to improve its speed. Right now I'm handling a document with 5678 paragraphs, and it is taking over 30 minutes to process all the information. Do you have any suggestion?
I had tried to approaches without having success:
1 - I've tried to use the object TableOfContents, however I was not able to have a clean information and differentiate outline levels from the paragraphs.
2 - I've tried to adapt the code from here Getting the headings from a Word document, specially because of the use of the command _docSource.GetCrossReferenceItems(wdRefTypeHeading), also with no success
Here there is the image of the form, and the code I'm using.
Sub ProcessHeaders()
Dim j As Long
Dim Paragraph_Number() As Variant
Dim Paragraph_Content() As Variant
Dim Paragraph_Mapping() As Variant
j = 1
With UserForm1
If .ComboBox4.ListCount > 0 Then
.ComboBox4.Clear
End If
For i = 1 To wordDoc.Paragraphs.Count
If wordDoc.Paragraphs.Item(i).OutlineLevel = wdOutlineLevel1 _
Or wordDoc.Paragraphs.Item(i).OutlineLevel = wdOutlineLevel2 _
Or wordDoc.Paragraphs.Item(i).OutlineLevel = wdOutlineLevel3 _
Or wordDoc.Paragraphs.Item(i).OutlineLevel = wdOutlineLevel4 Then
If wordDoc.Paragraphs.Item(i).Range.ListFormat.ListString <> "" Then
ReDim Preserve Paragraph_Number(j)
ReDim Preserve Paragraph_Content(j)
Paragraph_Content(j) = wordDoc.Paragraphs.Item(i).Range.ListFormat.ListString & " " & Trim(Left(wordDoc.Paragraphs.Item(i).Range.Text, (Len(wordDoc.Paragraphs.Item(i).Range.Text) - 1)))
Paragraph_Number(j) = i
j = j + 1
End If
End If
Next i
ReDim Preserve Paragraph_Mapping(1 To UBound(Paragraph_Content), 1)
For i = 1 To UBound(Paragraph_Number)
Paragraph_Mapping(i, 0) = Paragraph_Content(i)
Paragraph_Mapping(i, 1) = Paragraph_Number(i)
Next i
.ComboBox4.List = Paragraph_Mapping
End With
End Sub
Edit 1 - I Achieve to reduce the time from 32 minutes to 8 minutes of execution with the code below. Any suggestions to improve even more? Thanks in advance
Sub ProcessHeaders()
Dim j As Long
Dim thisOutlineLevel As WdOutlineLevel
Dim thisHeader As String
Dim thisList As String
Dim ParagraphCount As Long
Dim Paragraph_Number_Base() As Variant
Dim Paragraph_Content_Base() As Variant
Dim Paragraph_ListItem_Base() As Variant
Dim ParagraphContent() As Variant
Dim ParagraphNumber() As Variant
Dim Paragraph_Mapping() As Variant
Dim StartTime As Double
Dim MinutesElapsed As String
j = 1
With UserForm1
If .ComboBox4.ListCount > 0 Then
.ComboBox4.Clear
End If
ParagraphCount = wordDoc.Paragraphs.Count
ReDim Paragraph_Content_Base(ParagraphCount + 1)
ReDim Paragraph_ListItem_Base(ParagraphCount + 1)
ReDim Paragraph_Number_Base(ParagraphCount + 1)
StartTime = Timer
For i = 1 To ParagraphCount
MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")
UserForm1.Label7.Caption = "Reading Paragraphs. " & Format(i / ParagraphCount, "0%") & " | Total of Paragraphs Found: " & ParagraphCount & " | Time Elapsed: " _
& MinutesElapsed & " Minutes"
With wordDoc.Paragraphs.Item(i)
Select Case .OutlineLevel
Case wdOutlineLevelBodyText
GoTo ResumeNext
Case wdOutlineLevel1, wdOutlineLevel2, wdOutlineLevel3, wdOutlineLevel4
Paragraph_Content_Base(i) = .Range.Text
Paragraph_ListItem_Base(i) = .Range.ListFormat.ListString
Paragraph_Number_Base(i) = i
End Select
End With
ResumeNext:
Next i
MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")
UserForm1.Label7.Caption = ParagraphCount & " read on " & MinutesElapsed & " Minutes. Now, identifying the Headers"
For i = 0 To UBound(Paragraph_Content_Base)
If Paragraph_Content_Base(i) <> "" And Paragraph_ListItem_Base(i) <> "" Then
ReDim Preserve ParagraphContent(j)
ReDim Preserve ParagraphNumber(j)
ParagraphContent(j) = Trim(Paragraph_ListItem_Base(i)) & " " & Trim(Left(Paragraph_Content_Base(i), Len(Paragraph_Content_Base(i)) - 1))
ParagraphNumber(j) = Paragraph_Number_Base(i)
j = j + 1
End If
Next i
Erase Paragraph_Content_Base
Erase Paragraph_ListItem_Base
Erase Paragraph_Number_Base
ReDim Preserve Paragraph_Mapping(1 To UBound(ParagraphContent), 1)
For i = 1 To UBound(ParagraphNumber)
Paragraph_Mapping(i, 0) = ParagraphContent(i)
Paragraph_Mapping(i, 1) = ParagraphNumber(i)
Next i
.ComboBox4.List = Paragraph_Mapping
MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")
UserForm1.Label7.Caption = "Identifying Headers: " & j & " identified. Total Time: " & MinutesElapsed & " minutes"
End With
Edit 2 - With the Help of Cindy, the code which was initially running in 32 minutes right now is running on 32 seconds. Here is the final Code.
Sub ProcessHeaders()
Dim rng As Word.Range
Dim para As Word.Paragraph
Dim lstFormat As Word.ListFormat
Dim paraNr() As Variant
Dim paraContent() As Variant
Dim counter As Long, paraIndex As Long
Dim Paragraph_Mapping() As Variant
Dim ParagraphCount As Long
Dim i, j As Long
Dim StartTime As Double
Dim StartRealTime As Date
Dim MinutesElapsed As String
With UserForm1
If .ComboBox4.ListCount > 0 Then
.ComboBox4.Clear
End If
counter = 1
paraIndex = 1
i = 0
j = 1
StartTime = Timer
StartRealTime = Now
Set rng = wordDoc.Content
ParagraphCount = rng.ListParagraphs.Count
For Each para In rng.ListParagraphs
i = i + 1
Set lstFormat = para.Range.ListFormat
MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")
.Label7.Caption = "Reading Paragraphs. " & Format(i / ParagraphCount, "0%") & " | Total of Paragraphs Found: " & ParagraphCount & _
" | Start Time: " & StartRealTime & " | Time Elapsed: " & MinutesElapsed & " Minutes"
'CheckOutLine = rng.ListParagraphs.Item(1).OutlineLevel
If lstFormat.ListString <> "" And Len(lstFormat.ListString) >= 2 Then
ReDim Preserve paraNr(counter)
ReDim Preserve paraContent(counter)
paraContent(counter) = lstFormat.ListString & " " _
& Trim(Left(para.Range.Text, (Len(para.Range.Text) - 1)))
paraNr(counter) = i
wordDoc.Bookmarks.Add Name:="ExpContent" & i, Range:=para.Range
counter = counter + 1
End If
paraIndex = paraIndex + 1
Next
j = 1
ReDim Preserve Paragraph_Mapping(1 To UBound(paraNr), 1)
For i = UBound(paraNr) To 1 Step -1
Paragraph_Mapping(j, 0) = paraContent(i)
Paragraph_Mapping(j, 1) = paraNr(i)
j = j + 1
Next i
.ComboBox4.List = Paragraph_Mapping
MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")
.Label7.Caption = "Identifying Headers: " & j & " identified. Total Time: " & MinutesElapsed & " minutes"
End With
'
' For counter = 1 To UBound(paraNr)
' Debug.Print paraNr(counter) & vbTab & paraContent(counter)
' Next
End Sub
And After the user choose the paragraph, the bookmarks are being managed by this call
With objWord.Selection
BookmarkID = "ExpContent" & PositionReference
wordDoc.Bookmarks(BookmarkID).Select
.InsertParagraphBefore
End With
Once again, thank you
I think the fastest approach is going to be looping only the numbered paragraphs, rather than all paragraphs. This can be done using the ListParagraphs object. For example:
Sub IdOutlineLevels()
Dim rng As word.Range
Dim para As word.Paragraph
Dim lstFormat As word.ListFormat
Dim paraNr() As Variant
Dim paraContent() As Variant
Dim counter As Long, paraIndex As Long
counter = 1
paraIndex = 1
Set rng = ActiveDocument.content
For Each para In rng.ListParagraphs
Set lstFormat = para.Range.ListFormat
Select Case lstFormat.ListLevelNumber
Case 1, 2, 3, 4
If lstFormat.ListString <> "" Then
ReDim Preserve paraNr(counter)
ReDim Preserve paraContent(counter)
paraContent(counter) = lstFormat.ListString & " " _
& Trim(Left(para.Range.Text, (Len(para.Range.Text) - 1)))
paraNr(counter) = paraIndex
counter = counter + 1
ActiveDocument.Bookmarks.Add Name:="ExpContent" & counter, Range:=para.Range
End If
Case Else
End Select
paraIndex = paraIndex + 1
Next
For counter = 1 To UBound(paraNr)
Debug.Print paraNr(counter) & vbTab & paraContent(counter)
Next
End Sub
Rather than relying on the index number of the paragraph in the document to locate the paragraph again I've added bookmarks to each of the paragraphs using the same "counter" as the paragraph number. This is the technique Word, itself, uses for cross-referencing.
I've been struggling with this for a day now.
I have a list box that is populated with x items. Could be 1 - x
I need to take all the items in the list box and format them into a string
which I submit into an oracle database. I'm using INLIST on the SQL side and because of that I can only have a maximum of 100 items in my string.
So for example if I was to have 547 items in the listbox, I would iterate through all 547 items, but at every 100 I would submit into the database, returning my result into my collection class, finishing with the last 47.
here's what i have so far. There is some attempts to solve my problem in the code so if it's confusing i'll try to explain.
Public Function SearchBMS()
On Error GoTo HandleError
Dim rst As ADODB.Recordset
Dim sESN As String
Dim i As Integer
Dim x As Integer
Dim maxrec As Integer
Dim itemcnt As Integer
Dim iBlockCount As Integer
With frmEngineCampaignSearch.lstbxESNNumbers
itemcnt = .ListCount - 2
'iBlockCount = GetBlockCount(itemcnt)
x = 0
maxrec = 100
Debug.Assert itemcnt = 200
For i = 0 To itemcnt
For x = i To maxrec
MsgBox "test", vbOKOnly
i = i + 100
Next x
If i = itemcnt Then ' if I = last item than we put the closing parenthesis on our string
sESN = sESN & "'" & .list(i) & "'"
Else
sESN = sESN & "'" & .list(i) & "' , " ' otherwise there are more items so we seperate by comma
End If
If itemcnt <= 100 Then
Set rst = Nothing
'Set rst = rstGetCustomerInfo(sESN)
'LoadRSTToCollection rst
elseif
While x = maxrec
MsgBox "submit first 100", vbOKOnly
'Set rst = Nothing
'Set rst = rstGetCustomerInfo(sESN)
'LoadRSTToCollection rst
sESN = gC_sEMPTY_STRING
maxrec = maxrec + 100
Wend
x = x + 1
Next i
End With
HandleError:
If Err.Number > 0 Then
MsgBox Err.Number & ": " & Err.Description
End If
This function is to get the number of times I would have to perform the submission but i hit a road block on how to use it within the for loop
Public Function GetBlockCount(ByRef lItemCnt As Long) As Integer
Dim x As Double
If lItemCnt <= 100 Then
GetBlockCount = 1
Exit Function
ElseIf lItemCnt > 100 Then
x = Round(lItemCnt / 100)
If lItemCnt Mod 100 > 0 Then
x = x + 1
Else
GetBlockCount = x
Exit Function
End If
End If
End Function
Any help would be much appreciated.
I think you need to clean it out and make it more readable. Then look at it and the solution will be much clearer.
Here is a simple skeleton of what it should look like:
I = 100
Txt = Get100Requests(I)
Do While Txt <> ""
'use txt
I = I + 100
Txt = Get100Requests(I)
Loop
Function Get100Requests(FromItem As Integer) As String
If FromItem => frmEngineCampaignSearch.lstbxESNNumbers.ListCount Then Exit Function
Dim I As Integer
I + FromItem
Do While I < FromItem + 99 And I < frmEngineCampaignSearch.lstbxESNNumbers.ListCount
Get100Requests = Get100Requests & "'" & frmEngineCampaignSearch.lstbxESNNumbers.list(i) & "', "
I = I + 1
Loop
Get100Requests = Left(Get100Requests, Len(Get100Requests)-2)
Exit Function
Private Sub Command4_Click()
Dim x As Integer
r = InputBox("Enter row size ")
c = InputBox("Enter column size ")
ReDim arr(r, c) As Integer
For i = 0 To r - 1 Step 1
For j = 0 To c - 1 Step 1
arr(i, j) = InputBox("Enter row : " & (i + 1) & "column size : " & (j + 1))
Next j
Next i
For i = 0 To r - 1
For j = 0 To c - 1
Text1.Text = Text1.Text & " " & arr(i, j)
Next j
Text1.Text = Text1.Text & vbNewLine & vbCr
Next i
End Sub
This is my code for taking inputs in an array. Here everything is working fine except this line "Text1.Text = Text1.Text & vbNewLine & vbCr" here I am trying to print the array in row-column in 2D form inside a text box but its not happening "vbNewLine or vbcr" both are not working and my array is getting printed in a single line.
I suggest vbCrLf instead of vbNewLine & vbCr, and you need to make sure you have your textbox set to Multiline in the properties editor.