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
I track POD's Online. I do it from behind a proxy and use Microsoft Access in a query to execute the function to download the tracking information and parse it out. The base code is below. The function I use is TrackNew(trackingNumber). Each morning when I run this access.exe is asking for my credentials. I track from UPS and FedEx xml gateways and it doesn't ask for the proxy credentials. Is there a way that I can add the credentials inside my code so it doesn't prompt for this?
Here at the top is everything that makes this work. At the bottom is the actual function.
Private Enum HTTPequestType
HTTP_GET
HTTP_POST
HTTP_HEAD
End Enum
#If VBA7 Then
' 64-bit
Private Declare PtrSafe Function InternetGetConnectedState Lib "wininet"
(ByRef dwflags As LongPtr, _
ByVal dwReserved As Long) As Long
#Else
' pre 64-bit
Private Declare PtrSafe Function InternetGetConnectedState Lib "wininet"
(ByRef dwflags As Long, _
ByVal
dwReserved As Long) As Long
#End If
Private Const CONNECT_LAN As Long = &H2
Private Const CONNECT_MODEM As Long = &H1
Private Const CONNECT_PROXY As Long = &H4
Private Const CONNECT_OFFLINE As Long = &H20
Private Const CONNECT_CONFIGURED As Long = &H40
' Application Objects
Private xl As Access.Application
' misc symbols
Private Const CHAR_SPACE As String = " "
Private Const CHAR_UNDERSCORE As String = "_"
Private Const CHAR_COMMA As String = ","
Private Const CHAR_SLASH As String = "/"
Private Const AT_SYMBOL As String = "#"
' list of carriers (must be UPPER CASE, comma-delimited)
Private Const CARRIER_LIST As String =
"UPS,UPS1,UPS2,UPS3,UPS4,UPS5,UPS6,UPS7,UPS8,NEW,DHL,DHL1,FEDEX,FEDEX2,FEDEX3,FEDEX4,FEDEX5,HOLLAND,CONWAY,ABF,CEVA,USPS,TNT,YRCREGIONAL,YRC,NEMF,A1,RWORLDCOURIER,BLUEDART,TCIXPS,PUROLATOR,EXPINT,CMACGM,SAFM,PLG,DHL,ONTRAC,AAACT,RLC,ODFL,SAIA,DHLGLOBAL,LASERSHIP"
' MSXML stuff
Private Const MSXML_VERSION As String = "6.0"
' error Msgs
Private Const UNKNOWN_CARRIER As String = "Unknown carrier"
Private Const ERROR_MSG As String = "Error"
Private Const PACKAGE_NOT_FOUND As String = "Package Not Found"
Private Const MSIE_ERROR As String = "Cannot start Internet Explorer."
Private Const MSXML_ERROR As String = "Cannot start MSXML 6.0."
Private Const MSHTML_ERROR As String = "Cannot load MSHTML Object library."
' URLs for each carrier
Private Const NEWUrl As String = "https://www.newpenn.com/embeddable-tracking-results/?track="
'
' system functions
'
Private Function GetAppTitle() As String
GetAppTitle = App.Title & " " & App.Major & "." & App.Minor & "." & App.Revision
End Function
Private Function IsWindowsOS() As Boolean
' true if operating system is Windows
IsWindowsOS = (GetWindowsOS Like "*Win*")
End Function
'
' required addin procedures
'
Private Sub AddinInstance_OnAddInsUpdate(custom() As Variant)
' needed for operation
Exit Sub
End Sub
Private Sub AddinInstance_OnStartupComplete(custom() As Variant)
' needed for operation
Exit Sub
End Sub
' helper functions
Private Function GetRequestType(reqType As HTTPequestType) As String
Select Case reqType
Case 1
GetRequestType = "POST"
Case 2
GetRequestType = "HEAD"
Case Else ' GET is default
GetRequestType = "GET"
End Select
End Function
Private Function IsValidCarrier(CarrierName As String) As Boolean
' returns TRUE if the given carrier is on the global list
Dim carriers() As String
carriers = Split(CARRIER_LIST, ",")
IsValidCarrier = (UBound(Filter(carriers, CarrierName)) > -1)
End Function
Private Function GetHTMLAnchors(htmlDoc As Object) As Object ' MSHTML.IHTMLElementCollection
On Error Resume Next
Set GetHTMLAnchors = htmlDoc.anchors
End Function
Private Function LoadError(xmlDoc As Object) As Boolean
' checks if a xml file load error occurred
LoadError = (xmlDoc.parseError.ErrorCode <> 0)
End Function
Private Function GetRootNode(xmlDoc As Object) As Object
' returns root node
Set GetRootNode = xmlDoc.DocumentElement
End Function
Private Function GetNode(parentNode As Object, nodeNumber As Long) As Object
On Error Resume Next
' if parentNode is a MSXML2.IXMLDOMNodeList
Set GetNode = parentNode.Item(nodeNumber - 1)
' if parentNode is a MSXML2.IXMLDOMNode
If GetNode Is Nothing Then
Set GetNode = parentNode.ChildNodes(nodeNumber - 1)
End If
End Function
Private Function CreateFile(fileName As String, contents As String) As String
' creates file from string contents
Dim TempFile As String
Dim nextFileNum As Long
nextFileNum = FreeFile
TempFile = fileName
Open TempFile For Output As #nextFileNum
Print #nextFileNum, contents
Close #nextFileNum
CreateFile = TempFile
End Function
Here is where it prompts me for the windows domain credentials for the proxy.
Private Function GetResponse(xml As Object, requestType As HTTPequestType, _
destinationURL As String, Optional async As Boolean, _
Optional requestHeaders As Variant, Optional postContent As String) As String
Dim reqType As String
Dim response As String
Dim i As Long
reqType = GetRequestType(requestType)
With xml
.Open reqType, destinationURL, async
' check for headers
If Not IsMissing(requestHeaders) Then
For i = LBound(requestHeaders) To UBound(requestHeaders)
.setRequestHeader requestHeaders(i, 1), requestHeaders(i, 2)
Next i
End If
' if HTTP POST, need to send contents
' will not harm GET or HEAD requests
.Send (postContent)
' if HEAD request, return headers, not response
If reqType = "HEAD" Then
response = xml.getAllResponseHeaders
Else
response = xml.responseText
End If
End With
GetResponse = response
End Function
Private Function GetRequestHeaders() As Variant
Dim tempArray(1 To 1, 1 To 2) As Variant
tempArray(1, 1) = "Content-Type"
tempArray(1, 2) = "application/x-www-form-urlencoded"
GetRequestHeaders = tempArray
End Function
' major objects
Private Function GetMSIE() As Object ' InternetExplorer.Application
On Error Resume Next
Set GetMSIE = CreateObject("InternetExplorer.Application")
End Function
Private Function CreateHTMLDoc() As Object ' MSHTML.HTMLDocument
On Error Resume Next
Set CreateHTMLDoc = CreateObject("htmlfile")
End Function
Private Function GetMSXML() As Object ' MSXML2.XMLHTTP60
On Error Resume Next
Set GetMSXML = CreateObject("MSXML2.XMLHTTP" & IIf(Len(MSXML_VERSION) = 0, "", "." & MSXML_VERSION))
End Function
Private Function GetServerMSXML() As Object
On Error Resume Next
Set GetServerMSXML = CreateObject("MSXML2.ServerXMLHTTP" &
IIf(Len(MSXML_VERSION) = 0, "", "." & MSXML_VERSION))
End Function
Private Function CreateXMLDoc() As Object ' MSXML2.DOMDocument60
On Error Resume Next
Set CreateXMLDoc = CreateObject("MSXML2.DOMDocument" & IIf(Len(MSXML_VERSION) = 0, "", "." & MSXML_VERSION))
End Function
' XMLHTTP or MSIE
'''''Private Function GetMSXMLWebResponse(URL As String) As String
''''' Dim webObject As Object ' MSXML2.XMLHTTP60
''''' Set webObject = GetMSXML
''''' If webObject Is Nothing Then ' cannot start MSXML6
''''' Exit Function
''''' End If
''''' ' open URL and scrape result
''''' With webObject
''''' .Open "GET", URL, False
''''' .send
''''' End With
''''' GetMSXMLWebResponse = webObject.responseText
'''''End Function
Private Function GetMSIEWebResponse(URL As String) As String
Dim webObject As Object ' InternetExplorer.Application
Set webObject = GetMSIE
If webObject Is Nothing Then ' cannot start MSIE
Exit Function
End If
'open the url
webObject.navigate URL
'wait for the site to be ready
Do Until webObject.readyState = 4 ' READYSTATE_COMPLETE
DoEvents
Loop
'read the text from the body of the site
GetMSIEWebResponse = webObject.Document.body.innerText
webObject.Quit
End Function
Here is the actual tracking code:
Private Function TrackNEW(trackingNumber As String) As String
Dim xml As Object
Dim tempString As String
Dim htmlDoc As Object ' MSHTML.HTMLDocument
Dim htmlBody As Object ' MSHTML.htmlBody
Dim anchors As Object ' MSHTML.IHTMLElementCollection
Dim anchor As Object ' MSHTML.IHTMLElement
Dim dda As Object ' MSHTML.IHTMLElementCollection
Dim ddb As Object
Dim ddc As Object
Dim ddd As Object
Dim span As Object
Dim div As Object
Dim class As Object ' MSHTML.IHTMLElement
Set xml = GetMSXML
If xml Is Nothing Then ' cannot start MSXML 6.0
TrackNEW = MSXML_ERROR
Exit Function
End If
tempString = GetResponse(xml, HTTP_GET, NEWUrl & trackingNumber, False)
If Len(tempString) = 0 Then
MsgBox "5"
TrackNEW = ERROR_MSG
Exit Function
End If
Set htmlDoc = CreateHTMLDoc
If htmlDoc Is Nothing Then ' cannot reference MSHTML object library
MsgBox "6"
TrackNEW = MSHTML_ERROR
Exit Function
End If
On Error Resume Next
Set htmlBody = htmlDoc.body
htmlBody.innerHTML = tempString
Set dda = htmlDoc.getElementsByTagName("span")
Set ddb = htmlDoc.getElementsByTagName("span")
Set ddc = htmlDoc.getElementsByTagName("span")
Set ddd = htmlDoc.getElementsByTagName("div")
Item = 1
For Each Strg4 In ddd
For ItemNumber4 = 400 To 450
Strg4 = ddd.Item(ItemNumber4).innerText
If InStr(Strg4, "Projected Delivery Date") >= 1 Then
Why = ItemNumber4
Strg4 = ddd.Item(Why).innerText
GoTo Line8
Else
End If
Next ItemNumber4
Next Strg4
GoTo Line9
Exit Function
Line8:
TrackNEW = "INTRANSIT" & "|" & Right(Strg4, 11)
Exit Function
Line9:
Item = 1
For Each Strg In dda
For ItemNumber = 160 To 200
Strg = dda.Item(ItemNumber).innerText
If InStr(Strg, "DELIVERED") >= 1 Then
That = ItemNumber
Strg = dda.Item(That).innerText
GoTo Line2
Else
End If
Next ItemNumber
Next Strg
GoTo Line1
Line2:
Item2 = 1
For Each Strg2 In ddb
For ItemNumber2 = 160 To 200
Strg2 = ddb.Item(ItemNumber2).innerText
If InStr(Strg2, "DELIVERED") >= 1 Then
This = ItemNumber2 + 3
Strg2 = ddb.Item(This).innerText
GoTo Line3
Else
End If
Next ItemNumber2
Next Strg2
GoTo Line1
Line3:
Item3 = 1
For Each Strg3 In ddb
For ItemNumber3 = 160 To 200
Strg3 = ddb.Item(ItemNumber3).innerText
If InStr(Strg3, "DELIVERED") >= 1 Then
How = ItemNumber3 + 5
Strg3 = ddc.Item(How).innerText
GoTo Line4
Else
End If
Next ItemNumber3
Next Strg3
GoTo Line1
Line4:
TrackNEW = Strg & "|" & Strg2 & "|" & Strg3
Set xml = Nothing
Set htmlDoc = Nothing ' MSHTML.HTMLDocument
Set htmlBody = Nothing ' MSHTML.htmlBody
Set anchors = Nothing ' MSHTML.IHTMLElementCollection
Set anchor = Nothing ' MSHTML.IHTMLElement
Set dda = Nothing
Exit Function
Line1:
TrackNEW = "TRACKING|CANNOT|BE|FOUND"
Set xml = Nothing
Set htmlDoc = Nothing ' MSHTML.HTMLDocument
Set htmlBody = Nothing ' MSHTML.htmlBody
Set anchors = Nothing ' MSHTML.IHTMLElementCollection
Set anchor = Nothing ' MSHTML.IHTMLElement
Set dda = Nothing
Exit Function
End Function
Any help would be appreciated. I need the actual lines of code or reference that would get around it from prompting me for the windows credentials the proxy.
I found this snippet of code. Under the GETMSXML i could add this?
'Set GetMSXML = CreateObject("MSXML2.ServerXMLHTTP" & IIf(Len(MSXML_VERSION) = 0, "", "." & MSXML_VERSION))
'xmlhttp.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
'GetMSXML.setProxy 2, "proxy.website.com:8080"
'GetMSXML.setProxyCredentials "user", "password"
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.
I have a case in which I have field name as Order date for which I need to make it as always valid and it should be valid always.
Below is the script I tried.
Public Function getFolderDetails_FromPath_ForEmailInvoice(ByVal pXDoc As CASCADELib.CscXDocument) As String
On Error GoTo PROC_ERR
Const cProcName = "getFolderDetails_FromPath_ForEmailInvoice"
DbgOut(cProcName, Err, "Start")
Dim FullPath As String
Dim PathArry() As String
Dim FolderName As String
Dim FolderProp() As String
Dim xfolder As CscXFolder
Set xfolder = pXDoc.ParentFolder
While Not xfolder.IsRootFolder
Set xfolder = xfolder.ParentFolder
Wend
'Added below line for KTM testing
'FullPath="F:\EmailImport\chirag#gmail.com_08-01-2014_00-00-00\Demo_Manipulados_02.TIF"
If xfolder.XValues.ItemExists("AC_FIELD_OriginalFileName") Then
FullPath= xfolder.XValues.ItemByName("AC_FIELD_OriginalFileName").Value
End If
PathArry() = Split(FullPath,"\")
FolderName = PathArry(UBound(PathArry())-1)
FolderProp() = Split(FolderName,"_")
If CInt(UBound(FolderProp()))=2 Then
If(ValidateEmailAddress(FolderProp(0))) Then
pXDoc.Fields.ItemByName("Email_ID").Text = FolderProp(0)
pXDoc.Fields.ItemByName("Email_ID").ForcedValid = True
pXDoc.Fields.ItemByName("ReceiveDate").Text = FolderProp(1)
ValidationForm.Fields.ItemByName("ReceiveDate").Enabled = False
pXDoc.Fields.ItemByName("ReceiveDate").OriginalValid = True
pXDoc.Fields.ItemByName("Email_Time").Text = FolderProp(2)
pXDoc.Fields.ItemByName("Email_Time").ForcedValid = True
Else
pXDoc.Fields.ItemByName("Email_ID").Text = ""
pXDoc.Fields.ItemByName("Email_ID").ForcedValid = True
pXDoc.Fields.ItemByName("Email_Time").Text = ""
pXDoc.Fields.ItemByName("Email_Time").ForcedValid = True
End If
Else
pXDoc.Fields.ItemByName("Email_ID").Text = ""
pXDoc.Fields.ItemByName("Email_ID").ForcedValid = True
pXDoc.Fields.ItemByName("Email_Time").Text = ""
pXDoc.Fields.ItemByName("Email_Time").ForcedValid = True
End If
Use this property to make field valid always true:
pXDoc.Fields.ItemByName("Email_Time").ExtractionConfident = True
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)