I am trying to adapt this answer, which I believe is in VB.NET, for use with Outlook VBA.
I made some progress by getting the syntax corrected for VBA, but I do not know how to resolve "Compile error: User-defined type not defined" on the line
Dim CurrentXML As XmlDocument
Tool > References includes Microsoft XML, v6.0 but searching for XmlDocument in Object Browser returns no results.
The complete code is as follows:
Sub Search2()
' https://stackoverflow.com/a/50145011/18573
Dim sFilter As String
Dim CurrentExplorer As Outlook.Explorer
Set CurrentExplorer = Nothing
Dim CurrentView As Outlook.View
Set CurrentView = Nothing
' ERROR ON THE FOLLOWING LINE
Dim CurrentXML As XmlDocument
Set CurrentXML = New XmlDocument
Dim CurrentFilterNodes, CurrentViewNodes As XmlNodeList
Dim CurrentFilterNode, CurrentParentNode As XmlNode
sFilter = "urn:schemas:httpmail:subject LIKE '%Build Error%'"
CurrentExplorer = TryCast(ExplorerObj, Outlook.Explorer)
If (CurrentExplorer Is Not Nothing) Then
CurrentView = CurrentExplorer.CurrentView
If (CurrentView Is Not Nothing) Then
CurrentXML.LoadXML (CurrentView.xml)
CurrentFilterNodes = _
CurrentXML.getElementsByTagName("filter")
If CurrentFilterNodes.Count > 0 Then
For y = 0 To CurrentFilterNodes.Count - 1
CurrentFilterNode = CurrentFilterNodes(y)
If CurrentFilterNode.HasChildNodes Then
For i = CurrentFilterNode.ChildNodes.Count - 1 To 0 Step -1
CurrentFilterNode.RemoveChild (CurrentFilterNode.ChildNodes(i))
Next i
End If
Next y
CurrentFilterNode = CurrentFilterNodes(0)
CurrentFilterNode.appendChild ( _
CurrentXML.createTextNode(sFilter))
Else
CurrentViewNodes = CurrentXML.getElementsByTagName("view")
If CurrentViewNodes Is Not Nothing Then
CurrentParentNode = CurrentViewNodes(0)
CurrentFilterNode = CurrentXML.createElement("filter")
CurrentParentNode.appendChild (CurrentFilterNode)
CurrentFilterNode.appendChild (CurrentXML.createTextNode(sFilter))
End If
End If
CurrentView.xml = CurrentXML.InnerXml
CurrentView.Apply
Marshal.ReleaseComObject (CurrentView)
End If
End Sub
The VBA code for Outlook should look like as follows
Option Explicit
Sub Search2()
' https://stackoverflow.com/a/50145011/18573
' Add reference Microsoft XML, v6.0
Dim sFilter As String
Dim oExplorer As Explorer
Dim oView As View
Dim oXML As DOMDocument60
Dim cFilterNodes As IXMLDOMNodeList
Dim cViewNodes As IXMLDOMNodeList
Dim oFilterNode As IXMLDOMNode
Dim oParentNode As IXMLDOMNode
Dim y As Long
Dim i As Long
sFilter = "urn:schemas:httpmail:subject LIKE '%Build Error%'"
Set oXML = New DOMDocument60
Set oExplorer = ActiveExplorer
If Not oExplorer Is Nothing Then
Set oView = oExplorer.CurrentView
If Not oView Is Nothing Then
oXML.LoadXML oView.XML
Set cFilterNodes = oXML.getElementsByTagName("filter")
If cFilterNodes.Length > 0 Then
For y = 0 To cFilterNodes.Length - 1
Set oFilterNode = cFilterNodes(y)
If oFilterNode.HasChildNodes Then
For i = oFilterNode.ChildNodes.Length - 1 To 0 Step -1
oFilterNode.RemoveChild oFilterNode.ChildNodes(i)
Next
End If
Next
Set oFilterNode = cFilterNodes(0)
oFilterNode.appendChild oXML.createTextNode(sFilter)
Else
Set cViewNodes = oXML.getElementsByTagName("view")
If cViewNodes.Length > 0 Then
Set oParentNode = cViewNodes(0)
Set oFilterNode = oXML.createElement("filter")
oParentNode.appendChild oFilterNode
oFilterNode.appendChild oXML.createTextNode(sFilter)
End If
End If
Else
Set cViewNodes = oXML.getElementsByTagName("view")
If cViewNodes.Length > 0 Then
Set oParentNode = cViewNodes(0)
Set oFilterNode = oXML.createElement("filter")
oParentNode.appendChild oFilterNode
oFilterNode.appendChild oXML.createTextNode(sFilter)
End If
End If
oView.XML = oXML.XML
oView.Apply
End If
End Sub
Related
I have a code that creates new MS Access Databases. I'd like to add reference libraries to these newly created MS Access Databases.
Here is the code that I wrote but is not working:
Sub makeDb(fl As String)
Dim fs
Set fs = CreateObject("Scripting.FileSystemObject")
'check if the file already exists
If fs.FileExists(fl) = False Then
'create new ms access database
Dim accessApp As Access.Application
Set accessApp = New Access.Application
accessApp.DBEngine.CreateDatabase fl, dbLangGeneral
'loop through all references in current database and add them to the newly created dbs
Dim cur_vbProj As VBIDE.VBProject: Set cur_vbProj = Application.VBE.VBProjects(1)
Dim cur_vbRefs As VBIDE.References: Set cur_vbRefs = cur_vbProj.References
Dim cur_vbRef As VBIDE.Reference
For Each cur_vbRef In cur_vbRefs
Dim cur_guid As String: cur_guid = cur_vbRef.Guid
Dim cur_major As Long: cur_major = cur_vbRef.Major
Dim cur_minor As Long: cur_minor = cur_vbRef.Minor
'here is the code that doesn't work
Dim vbProj As VBIDE.VBProject: Set vbProj = accessApp.Application.VBE.VBProjects(1)
Dim vbRefs As VBIDE.References: Set vbRefs = vbProj.References
vbRefs.AddFromGuid Guid:=cur_guid, Major:=cur_major, Minor:=cur_minor
Next
accessApp.Quit
Set accessApp = Nothing
End If
End Sub
The line Set vbProj = accessApp.Application.VBE.VBProjects(1) throws Run-Time error '9' Subscript out of range. How should I modify the code? Is it even possible to add references to an outside database?
Following works for me:
Sub makeDb(f1 As String)
Dim accApp As Access.Application
Dim cur_vbRefs As References
Dim cur_vbRef As Reference
If Dir(f1) = "" Then
Access.DBEngine.CreateDatabase f1, dbLangGeneral
Set accApp = New Access.Application
accApp.OpenCurrentDatabase f1
'loop through all references in current database and add them to the newly created dbs
Set cur_vbRefs = Application.References
For Each cur_vbRef In cur_vbRefs
On Error Resume Next
accApp.References.AddFromGuid cur_vbRef.Guid, cur_vbRef.Major, cur_vbRef.Minor
Next
End If
End Sub
Hi This is the exact function i am using while pulling the report from CMS R17. Error line is quoted in * Set cvsConn = New cvsConnection * stars.
Function CMSConn(sUserID As String, sPassword As String, sServerIP As String)
Dim cvsApp As cvsApplication
Dim cvsSrv As cvsServer
Dim cvsConn As cvsConnection
Dim iServer As Integer
Dim bConnected As Boolean
bConnected = False
Set cvsApp = New cvsApplication
Set cvsSrv = New cvsServer
***Set cvsConn = New cvsConnection***
'Checks to see if already connected to server
For iServer = 1 To cvsApp.Servers.Count
Set cvsSrv = cvsApp.Servers(iServer)
If cvsSrv.ServerKey Like "*\" & sServerIP & "\*\*\*" Then
bConnected = True
'MsgBox "Avaya Connected! Click OK to proceed."
Exit For
End If
Next iServer
'Initiates connection if one not already established
If bConnected = False Then
If cvsApp.CreateServer(sUserID, sPassword, "", sServerIP, False, "ENU",
cvsSrv, cvsConn) Then
If cvsConn.Login(sUserID, sPassword, sServerIP, "ENU") Then
End If
End If
End If
'Executes CMS report
Dim cvsRepInfo As Object
Dim cvsRepProp As Object
Dim cvsLog As Object
Dim b As Boolean
On Error Resume Next
cvsSrv.Reports.ACD = 1
Set cvsRepInfo = cvsSrv.Reports.Reports("Historical\Designer\Skill Interval SvcLvl")
If cvsRepInfo Is Nothing Then
If cvsSrv.Interactive Then
MsgBox "The report was not found on ACD.", vbCritical Or vbOKOnly,
"Avaya CMS Supervisor"
Else
Set cvsLog = CreateObject("ACSERR.cvsLog")
cvsLog.AutoLogWrite "The report was not found on ACD."
Set cvsLog = Nothing
End If
Else
b = cvsSrv.Reports.CreateReport(cvsRepInfo, cvsRepProp)
If b Then
Application.DisplayAlerts = False
cvsRepProp.Window.Top = 40
cvsRepProp.Window.Left = 40
cvsRepProp.Window.Width = 40
cvsRepProp.Window.Height = 40
cvsRepProp.SetProperty "Splits/Skills",
ThisWorkbook.Sheets("DAILY").Range("x7").Value
cvsRepProp.SetProperty "Date",
ThisWorkbook.Sheets("DAILY").Range("x8").Value
cvsRepProp.SetProperty "Times",
ThisWorkbook.Sheets("DAILY").Range("x9").Value
b = cvsRepProp.ExportData("", 9, 0, False, True, True)
'Closes report
If bConnected = True Then
cvsRepProp.Quit
Else
If Not cvsSrv.Interactive Then cvsSrv.ActiveTasks.Remove
cvsRepProp.TaskID
End If
Set cvsRepProp = Nothing
End If
End If
'Terminates server instance and connection
Set cvsRepInfo = Nothing
If Not cvsSrv.Interactive Then cvsApp.Servers.Remove cvsSrv.ServerKey
If bConnected = False Then
cvsConn.Logout
cvsConn.Disconnect
cvsSrv.Connected = False
End If
Set cvsConn = Nothing
Set cvsSrv = Nothing
Set cvsApp = Nothing
End Function
End Sub
Sub Initialize
On Error GoTo e
Dim session As New NotesSession, db As NotesDatabase, view As NotesView
Dim nvec As NotesViewEntryCollection
Dim c As integer
Set db = session.currentdatabase
Set view = db.getView("Locked Out Users")
Set nvec = view.Allentries
c = nvec.count
If c > 0 Then
Call nvec.Removeall(true)
' Send notification
Dim sarr(1) As String
sarr(0) = "john.doe#acme.com"
sarr(1) = "foo#acme.com"
Dim mdoc As NotesDocument, rt As notesrichtextitem
Set mdoc = db.createdocument
mdoc.Form = "Memo"
mdoc.Subject = "Removed " + CStr(c) + " Locked out users on mypage"
Set rt = mdoc.Createrichtextitem("Body")
Call rt.Appendtext("Removed " + CStr(c) + " Locked out users")
Call rt.Addnewline(1)
Call rt.Appendtext("Click to open lockout database")
Call rt.Appenddoclink(db,"Lockout")
Call mdoc.Send(False, sarr)
End If
Exit Sub
e:
Print Error,erl
End Sub
I’m a beginner in Lotus Domino it I have some question , It's possible to change this script to delate only locked users with specified name?
I added something like that:
Dim nam As NotesName
Dim c As integer
Set db = session.currentdatabase
Set nam.OrgUnit1 = (“GD”)
Set view = db.getView("Locked Out Users")
Set nvec.OrgUnit1 = view.Allentries
c = nvec.count
If c > 0 Then
In my case I need delete all group person how has specified dc, for example Robert Kowalski/GD/Company everybody how has in name dc=GD?
There are at least 2 ways to achieve your request.
First you can copy the view "Locked Out Users" and change the selection formula to only include your OU.
The other option is something like
dim doc as notesdocument
dim nextDoc as notesdocument
set doc = view.getfirstdocument()
while not doc is nothing
set nextDoc = view.getnextDocument(doc)
set nam = new notesname(doc.getItemValue("[NAMEITEM]")(0))
if strcompare(nam.orgUnit1,"GD",5)=0 then
call doc.remove(true,false)
end if
set doc = nextDoc
wend
Sub Initialize
On Error GoTo e
Dim session As New NotesSession, db As NotesDatabase, view As NotesView
Dim nvec As NotesViewEntryCollection
Dim c As integer
Set db = session.currentdatabase
dim doc as notesdocument
dim nextDoc as notesdocument
set doc = view.getfirstdocument()
while not doc is nothing
set nextDoc = view.getnextDocument(doc)
set nam = new notesname(doc.getItemValue("[NAMEITEM]")(0))
if strcompare(nam.orgUnit1,"GD",5)=0 then
call doc.remove(true,false)
end if
set doc = nextDoc
wend
Set view = db.getView("Locked Out Users")
Set nvec = view.Allentries
c = nvec.count
If c > 0 Then
Call nvec.Removeall(true)
' Send notification
Dim sarr(1) As String
sarr(0) = "john.doe#acme.com"
sarr(1) = "foo#acme.com"
Dim mdoc As NotesDocument, rt As notesrichtextitem
Set mdoc = db.createdocument
mdoc.Form = "Memo"
mdoc.Subject = "Removed " + CStr(c) + " Locked out users on mypage"
Set rt = mdoc.Createrichtextitem("Body")
Call rt.Appendtext("Removed " + CStr(c) + " Locked out users")
Call rt.Addnewline(1)
Call rt.Appendtext("Click to open lockout database")
Call rt.Appenddoclink(db,"Lockout")
Call mdoc.Send(False, sarr)
End If
Exit Sub
e:
Print Error,erl
End Sub
Thank You #umeli for Yours responce. I think now
it should work.
As the title says, I'm having issues with enumerating and outputting item in my sent items folder in outlook. Specifically I'm looking for sent tasks. It keeps telling me there's nothing in the folder, when there is. The code is:
Private Sub GetSentTasks(objApp As Microsoft.Office.Interop.Outlook.Application)
Dim objNS As Outlook.NameSpace = objApp.GetNamespace("MAPI")
Dim folder As Outlook.MAPIFolder = _
objNS.GetDefaultFolder( _
Outlook.OlDefaultFolders.olFolderSentMail)
Dim searchCriteria As String = "[MessageClass] = 'IPM.TaskRequest'"
Dim strBuilder As StringBuilder = Nothing
Dim counter As Integer = 0
Dim taskItem As Outlook._TaskItem = Nothing
Dim folderItems As Outlook.Items = Nothing
Dim resultItem As Object = Nothing
Dim TTDcounter As Integer = 0
Try
folderItems = folder.Items
folderItems.IncludeRecurrences = True
If (folderItems.Count > 0) Then
resultItem = folderItems.Find(searchCriteria)
If Not IsNothing(resultItem) Then
strBuilder = New StringBuilder()
Do
If (TypeOf (resultItem) Is Outlook._TaskRequestItem) Then
counter += 1
taskItem = resultItem
'If taskItem.Categories = "TTD" Then
TTDcounter += 1
Dim listarray() As String = {taskItem.Delegator, taskItem.Subject, taskItem.DueDate, stripEstComp(taskItem.Body.ToString())}
taskPaneControl3.ListView1.Items.Add(TTDcounter).SubItems.AddRange(listarray)
'End If
End If
Marshal.ReleaseComObject(resultItem)
resultItem = folderItems.FindNext()
Loop Until IsNothing(resultItem)
End If
End If
If Not IsNothing(strBuilder) Then
Debug.WriteLine(strBuilder.ToString())
Else
Debug.WriteLine("There is no match in the " + _
folder.Name + " folder.")
End If
Catch ex As Exception
System.Windows.Forms.MessageBox.Show(ex.Message)
Finally
If Not IsNothing(folderItems) Then Marshal.ReleaseComObject(folderItems)
End Try
End Sub
I have a VB6 application that calls a Crystal Report XI Report. However when I try to change the connection info I get a type mismatch. Any help would be appreciated.
Dim Report As craxddrt.Report ' This is how Report is defined
ChangeReportTblLocation Report ' This is the function where the mismatch occurs
This is the definition of ChangeReportTblLocation:
Private Function ChangeReportTblLocation(ByRef pReport As craxddrt.Report) As Boolean
Dim ConnectionInfo As craxddrt.ConnectionProperties
Dim crxTables As craxddrt.DatabaseTables
Dim crxTable As craxddrt.DatabaseTable
Dim crxSections As craxddrt.Sections
Dim crxSection As craxddrt.section
Dim crxSubreportObj As craxddrt.SubreportObject
Dim crxReportObjects As craxddrt.ReportObjects
Dim crxSubreport As craxddrt.Report
Dim ReportObject As Object
Dim Y As Integer
Dim lsDatabase As String
On Error GoTo errHandle_CRTL
lsDatabase = GetCurrentUserRoot("SOFTWARE\COTTSYSTEMS\APP", "Database")
If lsDatabase = "" Then
lsDatabase = gConn.DefaultDatabase
End If
If lsDatabase = "" Then
lsDatabase = "frasys"
End If
With pReport
For Y = 1 To .Database.Tables.Count
Set ConnectionInfo = .Database.Tables(Y).ConnectionProperties
ConnectionInfo.DeleteAll
ConnectionInfo.Add "DSN", frasysdsn
ConnectionInfo.Add "Database", lsDatabase
'This is the Line that causes the type mismatch
.Database.Tables(Y).Location = lsDatabase & ".dbo." & Database.Tables(Y).Location
Next Y
Set crxSections = .Sections
For Each crxSection In crxSections
Set crxReportObjects = crxSection.ReportObjects
For Each ReportObject In crxReportObjects
If ReportObject.Kind = crSubreportObject Then
Set crxSubreportObj = ReportObject
Set crxSubreport = crxSubreportObj.OpenSubreport
Set crxTables = crxSubreport.Database.Tables
For Y = 1 To crxTables.Count
Set crxTable = crxTables.Item(Y)
crxTable.Location = lsDatabase & ".dbo." & crxTable.Location
Next Y
End If
Next ReportObject
Next crxSection
End With
Set ConnectionInfo = Nothing
Set crxTables = Nothing
Set crxTable = Nothing
Set crxSections = Nothing
Set crxSection = Nothing
Set crxSubreportObj = Nothing
Set crxReportObjects = Nothing
Set crxSubreport = Nothing
Set ReportObject = Nothing
ChangeReportTblLocation = True
Exit Function
errHandle_CRTL:
Screen.MousePointer = vbDefault
MsgBox err.Number, err.Description, "ChangeReportTblLocation", err.Source
End Function
I think its just a typo:
.Database.Tables(Y).Location = lsDatabase & ".dbo." & .Database.Tables(Y).Location
I've added a . before the second Database.Tables(Y).Location in this line.
This does suggest though that you aren't using Option Explicit in your code. I can't stress strongly enough how important it is to use this. It will save you lots of time looking for odd typos (like this) and save your code from doing all sorts of weird things.
try using
call ChangeReportTblLocation(Report)