i don't know why my code prints an error like "Object required" in line stpos = ARange.End
Public Function CreateNewWordDocument(TempPath)
Dim wd
Set App = CreateObject("Word.Application")
App.Visible = True
Set wd = App.Documents.Add(TempPath)
Set CreateNewWordDocument = wd
End Function
Public Function AddNewParagraphRange(ARange)
Dim NewParagraph
Dim NewRange
Dim I As Integer
I = ARange.Paragraphs.Count
ARange.InsertParagraphAfter
Set NewRange = ARange.Paragraphs(I).Range
NewRange.StartOf wdWord, wdMove
Set AddNewParagraphRange = NewRange
End Function
Public Sub RunForword(CurDBPath)
Dim R As Range
Set R = doc.Range
Dim aPart1
Dim aPart2
Dim aPart3
Set aPart1 = AddNewParagraphRange(R)
Set aPart2 = AddNewParagraphRange(R)
Set aPart3 = AddNewParagraphRange(R)
End Sub
Public Function WriteParagraphLn(ARange, text, StyleName) As Range
Dim stpos As Long
stpos = ARange.End
If Len(ARange) <= 2 Then
ARange.InsertAfter text
Else
ARange.InsertParagraphAfter
ARange.Document.Range(ARange.End, ARange.End + 1).Style = wdNormalStyleName
ARange.InsertAfter text
End If
If StyleName <> "" Then _
ARange.Document.Range(stpos, ARange.End).Style = StyleName
Set WriteParagraphLn = ARange.Document.Range(stpos, ARange.End)
End Function
Sub Creat_doc()
Dim TempPath As String
Dim doc
Set doc = CreateNewWordDocument(TempPath)
With doc
.PageSetup.TopMargin = CentimetersToPoints(2)
.PageSetup.BottomMargin = CentimetersToPoints(1.5)
End With
doc.Activate
Dim TextLine As String
TextLine = WriteParagraphLn("", "hello world", "Times New Roman")
doc.TypeText text:=TextLine
End Sub
Related
I add UserDefinedProperties in Outlook with the below code
Sub AddStatusProperties()
Dim objNamespace As NameSpace
Dim objFolder As Folder
Dim objProperty As UserDefinedProperty
Set objNamespace = Application.GetNamespace("MAPI")
Set objFolder = objNamespace.GetDefaultFolder(olFolderInbox)
With objFolder.UserDefinedProperties
Set objProperty = .Add("MyNotes1", olText, 1)
End With
End Sub
The user can add a value to MyNotes1 field in any email.
Public Sub EditField()
Dim obj As Object
Dim objProp As Outlook.UserProperty
Dim strNote As String, strAcct As String, strCurrent As String
Dim propertyAccessor As Outlook.propertyAccessor
Set obj = Application.ActiveExplorer.Selection.Item(1)
On Error Resume Next
Set UserProp = obj.UserProperties.Find("MyNotes1")
If Not UserProp Is Nothing Then
strCurrent = obj.UserProperties("MyNotes1").Value
End If
Dim varArrayList As Variant
Dim varArraySelected As Variant
varArrayList = Array("value1", "value2", "value3")
varArraySelected = SelectionBoxMulti(List:=varArrayList, Prompt:="Select one or more values", _
SelectionType:=fmMultiSelectMulti, Title:="Select multiple")
If Not IsEmpty(varArraySelected) Then 'not cancelled
For i = LBound(varArraySelected) To UBound(varArraySelected)
If strNote = "" Then
strNote = varArraySelected(i)
Else
strNote = strNote & ";" & varArraySelected(i)
End If
Next i
End If
Set objProp = obj.UserProperties.Add("MyNotes1", olText, True)
objProp.Value = strNote
obj.Save
Err.Clear
Set obj = Nothing
End Sub
I need to extract all email properties including the values available under MyNotes field to Excel. How do I recall MyNotes1 values?
This is the Excel code. The part I miss is "myArray(6, i - 1) = item.?????".
Public Sub getEmails()
On Error GoTo errhand:
Dim outlook As Object: Set outlook = CreateObject("Outlook.Application")
Dim ns As Object: Set ns = outlook.GetNamespace("MAPI")
'This option open a new window for you to select which folder you want to work with
Dim olFolder As Object: Set olFolder = ns.PickFolder
Dim emailCount As Long: emailCount = olFolder.Items.Count
Dim i As Long
Dim myArray As Variant
Dim item As Object
ReDim myArray(6, (emailCount - 1))
For i = 1 To emailCount
Set item = olFolder.Items(i)
If item.Class = 43 And item.ConversationID <> vbNullString Then
myArray(0, i - 1) = item.Subject
myArray(1, i - 1) = item.SenderName
myArray(2, i - 1) = item.To
myArray(3, i - 1) = item.CreationTime
myArray(4, i - 1) = item.ConversationID
myArray(5, i - 1) = item.Categories
'myArray(6, i - 1) = item.?????
End If
Next
With ActiveSheet
.Range("A1") = "Subject"
.Range("B1") = "From"
.Range("C1") = "To"
.Range("D1") = "Created"
.Range("E1") = "ConversationID"
.Range("F1") = "Category"
.Range("G1") = "MyNote"
.Range("A2:G" & (emailCount + 1)).Value = TransposeArray(myArray)
End With
Exit Sub
errhand:
Debug.Print Err.Number, Err.Description
End Sub
You already have code that retrieves that property
Set UserProp = item.UserProperties.Find("MyNotes1")
If Not UserProp Is Nothing Then
myArray(6, i - 1) = UserProp.Value
End If
I am a self-taught VBA Excel user and I am having trouble with some code that I am editing from a previous author for my needs. This code is supposed to look at a certain range of cells in the same column and export them with the respective tag in the next column over.
I keep getting an object defined error on the 29th line of the following code:
Public oServer As PISDK.Server
Public Sub SaveDataToPI()
Dim wsCurrent As Worksheet
Dim rValue As Double
Dim RowIndex As Integer
Dim strPITagName As String
Dim dtCurrent As Date
Dim blnSavedData As Boolean
'Dim bwLab As Double
'Dim bwAct As Double
'Dim bwDif As Double
'Dim MoistureLab As Double
'Dim MoistureAct As Double
'Dim MoistureDif As Double
With Application
.Cursor = xlWait
.StatusBar = "Sending Data To PI...."
.ScreenUpdating = True
End With
Set wsCurrent = ActiveSheet
With wsCurrent
'first column of data
For RowIndex = 5 To 500
If Len(EntryScreen2.Cells(RowIndex, 3).Value) < 1 Then
Exit For
End If
' Blank out error messages in column 4 if there
EntryScreen2.Cells(RowIndex, 4).Value = ""
Next
End With
With wsCurrent
'first column of data
For RowIndex = 5 To 500
If Len(EntryScreen2.Cells(RowIndex, 3).Value) < 1 Then
Exit For
End If
If Len(EntryScreen2.Cells(RowIndex, 2).Value) > 0 And Len(EntryScreen2.Cells(RowIndex, 3).Value) > 0 Then
'Save Data To PI
dtCurrent = wsCurrent.Range(wsCurrent.Cells(2, 2), wsCurrent.Cells(2, 2)).Value
Call SavePIData(EntryScreen2.Cells(RowIndex, 3).Value, EntryScreen2.Cells(RowIndex, 2).Value, dtCurrent, RowIndex)
EntryScreen2.Cells(RowIndex, 2).Value = ""
blnSavedData = True
End If
Next
End With
If blnSavedData = True Then MsgBox "Data Saved to PI, Check Column D for Errors"
With Application
.Cursor = xlDefault
.StatusBar = "Ready...."
.ScreenUpdating = True
End With
End Sub
Public Function GetServer(szServer As String) As PISDK.Server
'Dim oServer As PISDK.Server
Dim oCon As Object
Set oServer = Servers(szServer)
On Error Resume Next
If oServer.Connected = False Then
oServer.Open
End If
On Error GoTo 0
If oServer.Connected = False Then
Set oCon = CreateObject("PISDKdlg.Connections")
On Error Resume Next
oCon.Login oServer, , , False
End If
Set GetServer = oServer
End Function
Public Sub SavePIData(strPITagName As String, dblValue As Double, dtCurrent As Date, RowIndex As Integer)
Dim oTag As PIPoint
'Dim oServer As Server
On Error GoTo Error
Set oServer = GetServer("pksfpi")
Set oTag = oServer.PIPoints(strPITagName)
'Send Data to database
oTag.Data.UpdateValue dblValue, dtCurrent
Set oTag = Nothing
Exit Sub
Error:
EntryScreen2.Cells(RowIndex, 4).Value = Err.Description
End Sub
Public Sub SaveEditedDataToPI(strPITagName As String, dtCurrent As Date, dblValue As Double)
Dim oTag As PIPoint
'Dim oServer As Server
On Error Resume Next
' strPITagName , dtCurrent, rValue
Set oServer = GetServer("pksfpi")
Set oTag = oServer.PIPoints(strPITagName)
'Send Data to database
oTag.Data.UpdateValue dblValue, dtCurrent, dmReplaceOnlyDuplicates
Set oTag = Nothing
End Sub
If you find anything else wrong in my code, feel free to let me know so that I don't run into anymore problems.
Thanks!!
I have a folder that has emails with attachments and without attachments. i have the code for extracting the attachments names but if an email doesn't have attachments the code will stop. Any help is welcomed, thank you.
by jimmypena
Private Sub CommandButton2_Click()
Dim a As Attachments
Dim myitem As Folder
Dim myitem1 As MailItem
Dim j As Long
Dim i As Integer
Set myitem = Session.GetDefaultFolder(olFolderDrafts)
For i = 1 To myitem.Items.Count
If myitem.Items(i) = test1 Then
Set myitem1 = myitem.Items(i)
Set a = myitem1.Attachments
MsgBox a.Count
' added this code
For j = 1 To myitem1.Attachments.Count
MsgBox myitem1.Attachments.Item(i).DisplayName ' or .Filename
Next j
End If
Next i
End Sub
My code:
Sub EXPORT()
Const FOLDER_PATH = "\\Mailbox\Inbox\emails from them"
Dim olkMsg As Object, _
olkFld As Object, _
excApp As Object, _
excWkb As Object, _
excWks As Object, _
intRow As Integer, _
intCnt As Integer, _
strFileName As String, _
arrCells As Variant
strFileName = "C:\EXPORT"
If strFileName <> "" Then
Set excApp = CreateObject("Excel.Application")
Set excWkb = excApp.Workbooks.Add()
Set excWks = excWkb.ActiveSheet
excApp.DisplayAlerts = False
With excWks
.Cells(1, 1) = "ATTACH NAMES"
.Cells(1, 2) = "SENDER"
.Cells(1, 3) = "NR SUBJECT"
.Cells(1, 4) = "CATEGORIES"
End With
intRow = 2
Set olkFld = OpenOutlookFolder(FOLDER_PATH)
For Each olkMsg In olkFld.Items
If olkMsg.Class = olMail Then
arrCells = Split(GetCells(olkMsg.HTMLBody), Chr(255))
Dim Reg1 As RegExp
Dim M1 As MatchCollection
Dim M As match
Set Reg1 = New RegExp
With Reg1
.Pattern = "\s*[-]+\s*(\w*)\s*(\w*)"
.Global = True
End With
Set M1 = Reg1.Execute(olkMsg.Subject)
For Each M In M1
excWks.Cells(intRow, 3) = M
Next
Dim a As Attachments
Set a = olkMsg.Attachments
If Not a Is Nothing Then
excWks.Cells(intRow, 1) = olkMsg.Attachment.Filename
'excWks.Cells(intRow, 2) = olkMsg.SenderEmailAddress
End If
excWks.Cells(intRow, 2) = olkMsg.sender.GetExchangeUser.PrimarySmtpAddress
excWks.Cells(intRow, 4) = olkMsg.Categories
intRow = intRow + 1
intCnt = intCnt + 1
End If
Next
Set olkMsg = Nothing
excWkb.SaveAs strFileName, 52
excWkb.Close
End If
Set olkFld = Nothing
Set excWks = Nothing
Set excWkb = Nothing
Set excApp = Nothing
MsgBox "Ta dam! "
End Sub
edited
Set a = myitem1.Attachments
MsgBox a.Count
For j = 1 To myitem1.Attachments.Count
MsgBox myitem1.Attachments.Item(j).DisplayName ' or .Filename
Next j
as about your edited question, replace the following snippet
Dim a As Attachments
Set a = olkMsg.Attachments
If Not a Is Nothing Then
excWks.Cells(intRow, 1) = olkMsg.Attachment.Filename
'excWks.Cells(intRow, 2) = olkMsg.SenderEmailAddress
End If
with:
Dim a As Attachment
For Each a In olkMsg.Attachments
excWks.Cells(intRow, 1) = a.FileName
'excWks.Cells(intRow, 2) = a.SenderEmailAddress
Next a
which you must treat appropriately as for the intRow index.
if you are interested in only the first attachment then you could substitute the entire last code with this:
excWks.Cells(intRow, 1) = olkMsg.Attachments.Item(1).FileName
while if you are interested in all attachments then you'll have to rethink about your sheet report structure
Here is some working code in case anyone needs it.
The key word is found using the range.find function, once found the absolute line number is found. Then the selection function scrolls up line by line to find heading levels 1 and 2. The results are stored in array and pasted onto an excel spreadsheet once complete.
If anyone has a more elegant method please let me know.
'===================================================
'FIND KEY WORD AND ASSOCIATED LEVEL 1 AND 2 HEADINGS
'===================================================
Sub FIND_HDNG_2()
Dim SENTENCE As String
Dim hdng1name As String, hdng1No As String, hdng2name As String, hdng2No As String
Dim aRange As Range, Style_Range As Range
Dim CurPage As Integer, CurPage2 As Integer, CurPage3 As Integer
Dim hdng_STYLE As String
Dim LineNo As Integer, Hdng_LineNo As Integer
Dim SELECTION_PG_NO As Integer, RANGE_PG_NO As Integer
Dim HDNG_TXT As String
Dim ARRY(200, 5) As String
Dim COUNT As Integer
Dim HDNG1_FLAG As Boolean, HDNG2_FLAG As Boolean
Dim LINESUP As Integer
On Error Resume Next
COUNT = 1
Set aRange = ActiveDocument.Range
Do
aRange.Find.Text = "must" ' the KEY WORD I am looking for
aRange.Find.Execute Forward:=True
If aRange.Find.Found Then
'extract sentence
LineNo = GetAbsoluteLineNum(aRange)
RANGE_PG_NO = aRange.Information(wdActiveEndPageNumber)
aRange.Expand Unit:=wdSentence
aRange.Copy
SENTENCE = aRange.Text
aRange.Collapse wdCollapseEnd
'find heading name and number
Selection.GoTo What:=wdGoToLine, Which:=wdGoToAbsolute, COUNT:=LineNo 'go to line no of the range
LINESUP = 0
Do
LINESUP = LINESUP + 1
Selection.MoveUp Unit:=wdLine, COUNT:=1
Selection.HomeKey Unit:=wdLine
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
HDNG_TXT = Selection.Text
'reached first page without finding heading
SELECTION_PG_NO = Selection.Information(wdActiveEndPageNumber)
If SELECTION_PG_NO = 1 Then 'exit if on first page
hdng2No = "BLANK"
hdng2name = "BLANK"
Exit Do
End If
hdng_STYLE = Selection.STYLE
If hdng_STYLE = "Heading 1,Heading GHS" And HDNG1_FLAG = False Then
hdng1No = Selection.Paragraphs(1).Range.ListFormat.ListString
hdng1name = Selection.Sentences(1)
HDNG1_FLAG = True
Exit Do
End If
If hdng_STYLE = "Heading 2" And HDNG2_FLAG = False Then
hdng2No = Selection.Paragraphs(1).Range.ListFormat.ListString
hdng2name = Selection.Sentences(1)
HDNG2_FLAG = True
End If
Loop
End If
HDNG1_FLAG = False
HDNG2_FLAG = False
ARRY(COUNT, 1) = hdng1No
ARRY(COUNT, 2) = hdng1name
ARRY(COUNT, 3) = hdng2No
ARRY(COUNT, 4) = hdng2name
ARRY(COUNT, 5) = SENTENCE
COUNT = COUNT + 1
Loop While aRange.Find.Found
Call PASTE_RESULT_EXCEL(ARRY)
End Sub
'===================================================
'PASTE RESULTS TO EXCEL
'===================================================
Sub PASTE_RESULT_EXCEL(ByRef ARY() As String)
Dim appExcel As Object
Dim wb As Object
Dim ws As Object
Dim min As String
Dim filename As String
Dim X As Integer, Y As Integer
filename = "DOC_NAME"
Set appExcel = CreateObject("Excel.Application")
With appExcel
.Visible = True
Set wb = .Workbooks.Add
min = CStr(Minute(Now()))
wb.SaveAs "D:\IPL\" + filename + "--" + min + ".xlsx"
Set ws = wb.Worksheets(1)
For X = 1 To 200
For Y = 1 To 5
ws.Cells(X + 5, Y).Value2 = ARY(X, Y)
Next Y
Next X
Set ws = Nothing
Set wb = Nothing
Set appExcel = Nothing
End With
End Sub
'===================================================
'FIND ABSOLUTE LINE NUMBER OF KEY WORD
'===================================================
Function GetAbsoluteLineNum(r As Range) As Integer
Dim i1 As Integer, i2 As Integer, COUNTER As Integer, rTemp As Range
r.Select
Do
i1 = Selection.Information(wdFirstCharacterLineNumber)
Selection.GoTo What:=wdGoToLine, Which:=wdGoToPrevious, COUNT:=1, Name:=""
COUNTER = COUNTER + 1
i2 = Selection.Information(wdFirstCharacterLineNumber)
Loop Until i1 = i2
r.Select
GetAbsoluteLineNum = COUNTER
End Function
Public Function GetProfileDetails(FormID As String,ControlName As String ,ProfileName As String)
'Dim FormName As String: FormName = GetUserFormName(FormID)
Dim ProfileRange As range: Set ProfileRange = range("DYUI_Profile")
Dim TempRange As range: Set TempRange = Nothing
Dim i As Integer: i = 0
Dim ProfileColIndex As Integer: ProfileColIndex = getColumnIndex("Profile", ProfileRange)
Dim UserNameColIndex As Integer: UserNameColIndex = getColumnIndex("UserName", ProfileRange)
Dim PassowrdColindex As Integer: PassowrdColindex = getColumnIndex("Password", ProfileRange)
Dim URLColIndex As Integer: URLColIndex = getColumnIndex("URL", ProfileRange)
Dim RowCnt As Integer: RowCnt = ProfileRange.rows.Count
For i = 2 To RowCnt
If Trim(UCase(ProfileRange.rows.Cells(i, ProfileColIndex))) = Trim(UCase(ProfileName)) Then
If TempRange Is Nothing Then
Set TempRange = ProfileRange.rows(i)
Else
Set TempRange = Application.Union(TempRange, ProfileRange.rows(i))
End If
End If
Next i
For i = 1 To TempRange.rows.Count
FormName.ControlName.Text = TempRange.rows.Cells(i, UserNameColIndex).Value
FormName.ControlName.Text = TempRange.rows.Cells(i, PassowrdColindex).Value
FormName.ControlName.Text = TempRange.rows.Cells(i, URLColIndex).Value
Next i
Worksheets("Form_Output").Cells(1, 3).Value = FormName.ControlName.Value
Worksheets("Form_Output").Cells(1, 5).Value = FormName.ControlName.Value
Worksheets("Form_Output").Cells(1, 7).Value = FormName.ControlName.Value
End Function
You can't use a string form or control name like this. Pass the control object that you want to use:
Public Function GetProfileDetails(TextBox As TextBox, ProfileName As String)