borderAndreaVB free resources for Visual Basic developersborder
borderAndreaVB Visual Basic and VB.NET source code resources - Copyright © 1999-2014 Andrea Tincaniborder

AndreaVB | Forum | News | Downloads | Register | Help | Member List | Statistics | Search | PM | Profile

Print This Topic
Previous Topic (Recordset \"LIKE\" filter of a number column)Next Topic (Restore Database Problem) New Topic New Poll Post Reply
AndreaVB Forum : Database : Data Type Mismatch - What does it mean..??
Poster Message
Kenny
Level: Guest


icon Data Type Mismatch - What does it mean..??

Hello folks - I am in need of some assitance in trying to get a recordset to open in my program. Let me give you the details. I am building an application in VB6 that feeds from data in an A2K DB. I am trying to generate a recordset based on a specific field (CaseNumber (who's data type is AutoNumber)). The CaseNumber is data passed from another form. Here is the code that I am using:

Dim cxn As ADODB.Connection
     Dim rst As ADODB.Recordset
     Dim strSQL As String
    
     Set cxn = New ADODB.Connection
     Set rst = New ADODB.Recordset

     With cxn
          .ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & _
               "Cocuments and SettingsAll UsersDocumentsPNR DoctorPNR Doctor.mdb"
          .Open
     End With

     strSQL = _
          "SELECT ErrorData.CaseNumber " & _
          "FROM ErrorData " & _
          "WHERE ((ErrorData.CaseNumber) =  '" & frmAgentSearch.intCaseNumber & "');"

     rst.Open strSQL, cxn, adOpenStatic, adLockReadOnly, adCmdText

When I run this I get the following message:

Run Time Error '-2147217913 (80040e07)':
Data type mismatch in criteria expression.


I don't know what this means, what is causing it, or how to fix it. If anybody can provide me with any ideas of a solution I would really appreciate it...!

19-05-2003 at 10:23 PM
| Quote Reply
JLRodgers
Level: Moderator

Registered: 04-04-2002
Posts: 1652
icon Re: Data Type Mismatch - What does it mean..??

You're putting ' around the number, making it a string, just remove the '

____________________________
Everywhere's Local (classifieds, job postings, & more for everycity in the world - user entered)

19-05-2003 at 10:25 PM
View Profile Send Email to User Show All Posts Visit Homepage | Quote Reply
Kenny
Level: Guest

icon Re: Data Type Mismatch - What does it mean..??

Thank you JLRodgers - you saved the day..!!! I thought I had already tried that but obviously not.

20-05-2003 at 12:05 PM
| Quote Reply
~Bean~
Level: VB Guru


Registered: 07-04-2003
Posts: 480
icon Re: Data Type Mismatch - What does it mean..??

Since this is the second question I've seen raised regarding this error (in the past week) I thought I would post an explanation for some folks. There are times when this error can appear for strange reasons, but for the most part you get this error when you have assigned a variable a value that doesn't match the type you have defined for that variable...eg.,

'Simple Type Mismatch Error
Dim x As Integer 'Declare the Variable, and Define it's Type as an INTEGER
x = "String" 'Attempt to Assign the Variable a STRING Value


However...this is acceptable...

'Type match
Dim x As Integer
x = 1 'This is OK
x=1.1111111111 'This is ALSO OK, though x will still only equal 1 (an integer)


As I mentioned, this error can arise from a number of diff possibilities, but this is most common, and indeed, its also a variation of what Kenny ran into. And so the name of the error is actually quite descriptive of the error itself...you could say they "match"...(tee-hee)


FYI:

quote:
From VB Documentation:
Type mismatch

-The variable or property isn't of the correct type. For example, a variable that requires an integer value can't accept a string value unless the whole string can be recognized as an integer.
Try to make assignments only between compatibledata types. For example, an Integer can always be assigned to a Long, a Single can always be assigned to a Double, and any type (except auser-defined type) can be assigned to a Variant.

-An object was passed to aprocedure that is expecting a single property or value.
Pass the appropriate single property or call a method appropriate to the object.

-A module or project name was used where an expression was expected, for example:
Debug.Print MyModule
Specify an expression that can be displayed.

-You attempted to mix traditional Basic error handling with Variant values having the Error subtype (10, vbError), for example:
Error CVErr(n)

To regenerate an error, you must map it to an intrinsic Visual Basic or a user-defined error, and then generate that error.

A CVErr value can't be converted to Date. For example:
MyVar = CDate(CVErr(9))

Use a Select Case statement or some similar construct to map the return of CVErr to such a value.

-At run time, this error typically indicates that a Variant used in an expression has an incorrect subtype, or a Variant containing anarray appears in a Print # statement.
To print arrays, create a loop that displays each element individually.





____________________________
Eggheads unite! You have nothing to lose but your yolks.
20-05-2003 at 02:49 PM
View Profile Send Email to User Show All Posts Visit Homepage | Quote Reply
Kenny
Level: Guest

icon Re: Data Type Mismatch - What does it mean..??

Thanx Bean. I think I've got it now.

20-05-2003 at 03:56 PM
| Quote Reply
shijobaby
Level: Trainee

Registered: 03-12-2009
Posts: 1
icon Re: Data Type Mismatch - What does it mean..??

http://accessaidprogramming.blogspot.com/2009/12/type-mismatch-error-vbavbms-access.html

03-12-2009 at 12:50 PM
View Profile Send Email to User Show All Posts | Quote Reply
estatistics
Level: Trainee

Registered: 15-05-2013
Posts: 1
icon Re: Data Type Mismatch - What does it mean..??

i have the folloing api code for google analytics for Statistica


why did i get the message "missmatch...."?

'#Reference {C9E29001-3D45-11D4-9FF4-00C04FA0D540}#1.0#0#C:\Program Files\StatSoft\STATISTICA 10\stl_mgra.dll#STATISTICA Graphics Type Library#STATISTICAGraphics
'#Reference {140CB7E3-2327-4186-AEA5-BB353F338D13}#1.0#0#C:\PROGRA~1\StatSoft\STATIS~3\StaSpreadsheet.dll#StatSoft STATISTICA Spreadsheet Library#StaSpreadsheetLib
'#Reference {BE35B7EB-0D00-44D8-B3A5-0727DF5AD7C1}#1.0#0#C:\Program Files\StatSoft\STATISTICA 10\Dictionary.dll#StatSoft STATISTICA Dictionary Library#DICTIONARYLib
'#Reference {000204EF-0000-0000-C000-000000000046}#6.0#9#c:\windows\SysWow64\msvbvm60.dll#Visual Basic For Applications#VBA
'#Reference {F5078F18-C551-11D3-89B9-0000F81FE221}#6.0#0#C:\Windows\System32\msxml6.dll#Microsoft XML, v6.0#MSXML2

'This example macro will query the Google Analytics database and return various metrics/dimensions associated with external user visits to the
' user's organizational website.
'To use this macro, the user's organization must have an established Google Analytics account (obtainable here:
' http://www.google.com/analytics/) with a valid e-mail address and password available to the user.
'
'This example macro consists of one main procedure and seven (7) public and private sub-procedural functions:
'
'Sub Main - Contains the calls to the functions that execute the different steps in the macro.
'
'Function InitializeGranularityArray - Creates the array used to present time-frame options to the user in the function FilterGADataDialog
'Function InitializeMetricsArray - Creates the array used to present the user with various metric and dimension options in the
' function FilterGADataDialog
'Function AuthenticationDialog - Presents the input dialog for the user to enter his/her organization's valid Google Analytics e-mail address
' and password.
'Function getGAauthenticationToken - Uses the user-entered Google Analytics e-mail address and password to obtain the authentication token
' information necessary to obtain the desired Google Analytics metrics and dimensions data.
'Function getGAProfile - Uses the authentication token returned from the function getGAauthenticationToken to obtain associated profile information
' including account names, profile numbers, and profile titles for the user's organization.
'Function FilterGADataDialog - Presents the user with choices of profile titles, data ranges for which the metrics are desired, and a selection of
' up to six (6) different metrics possible at a single time.
'Function GetGAData - Uses the authentication token, profile, date range, and metric selection information to parse the XML Google Analytics data and
' return the desired information to the output spreadsheet.



'#Language "WWB-COM"

Option Base 1
Option Explicit

'Declaration of global variables

Dim sMetricsArray(0 To 18) As String 'By default, STATISTICA dialog arrays are zero-based, irrespective of the Option Explicit keywords.
Dim sGranularityArray(0 To 1) As String
Dim sGooglePass As String
Dim sGoogleMail As String
Dim sSessionToken As String
Dim sWebsitesArray() As Variant
Dim sProfilesArray() As Variant

Sub Main

If Not InitializeGranularityArray() Then Exit Sub 'Boolean functions return FALSE if error is encountered; subroutine where the error
If Not InitializeMetricsArray() Then Exit Sub 'occurs displays the error message.  Return of FALSE value stops the macro.
If Not AuthenticationDialog() Then Exit Sub

End Sub

Public Function AuthenticationDialog() As Boolean 'Presents dialog for user to enter Google Analytics e-mail address and password

AuthenticationDialog = True

On Error GoTo ErrAuthenticationDialog

Do
Begin Dialog UserDialog 400,154 ' %GRID:10,7,1,1
GroupBox 10,7,380,147,"Google Authentication Information",.GroupBox1
Text 30,42,90,21,"E-Mail: ",.Text1
TextBox 140,42,210,21,.TextBox1
Text 30,77,90,14,"Password: ",.Text2
TextBox 140,77,210,21,.TextBox2,-1
OKButton 100,119,100,21
CancelButton 220,119,80,21
End Dialog
Dim dlg As UserDialog

If Dialog (dlg) Then

sGoogleMail =  dlg.TextBox1
sGooglePass =  dlg.TextBox2

If sGoogleMail <> "" And sGooglePass <> "" Then 'Proceed only if user enters both a valid Google eMail address
'and the valid associated Google eMail password

If Not getGAauthenticationToken(sGoogleMail, sGooglePass, sSessionToken) Then Exit All 'Returns the session authentication token

sProfilesArray = GetGAProfiles(sSessionToken, False)

Dim i As Long
Dim lMax As Long

lMax = UBound(sProfilesArray,1)

ReDim sWebsitesArray(LBound(sProfilesArray,1) To UBound(sProfilesArray,1)) As Variant 'Dimension websites array to be same size as
'profiles array

For i = LBound(sProfilesArray,1) To UBound(sProfilesArray,1) 'Create one-dimension array of profile titles for presentation to the
sWebsitesArray(i) = sProfilesArray(i,2) 'user in FilterGADataDialog
Next i


If Not FilterGADataDialog() Then Exit Function 'Calls function to present user with profile, date range, metric &
'dimension data options
ElseIf sGoogleMail <> "" Then
MsgBox CStr("Please enter a password.")
ElseIf sGooglePass <> "" Then
MsgBox CStr("Please enter an e-mail address.")
Else
MsgBox CStr("Please enter values for both the e-mail address and the password.")
End If
Else
Exit Function

End If

Loop Until sGoogleMail <> "" And sGooglePass <> "" 'Don't proceed until user enters valid Google Analytics e-mail and password

Exit Function

ErrAuthenticationDialog:

AuthenticationDialog = False

MsgBox CStr("Error encountered while processing authentication dialog.  Procedure is closing." & vbCrLf & Err.Number & vbCrLf & Err.Description)

End Function


Public Function FilterGADataDialog() As Boolean

FilterGADataDialog = True

On Error GoTo ErrFilterGADataDialog

Dim bRunProc As Boolean
Dim dStartDate As Date
Dim dEndDate As Date

Do

bRunProc = True 'This flag is used to ensure that the user enters appropriate information: valid date ranges, valid profile, etc.

ReRunDialog:
Begin Dialog UserDialog 800,301,"Filters" ' %GRID:10,7,1,1
GroupBox 0,0,800,301,"Filter Data",.GroupBox1
DropListBox 160,28,210,21,sWebsitesArray(),.DropListBox1
Text 30,28,110,14,"Choose Profile:",.Text1
Text 30,70,110,14,"Metric:",.Text2
DropListBox 160,70,210,21,sMetricsArray(),.DropListBox2
OKButton 350,238,100,21
CancelButton 470,238,110,21
Text 30,105,90,14,"Granularity by:",.Text6
DropListBox 160,105,210,21,sGranularityArray(),.DropListBox4
GroupBox 400,28,370,182,"Dimensions (Select up to 6):",.GroupBox2
Text 30,133,340,14,"NOTE: Granularity by Week is selected by default.",.Text3
CheckBox 420,56,90,14,"Continent",.CheckBox1
CheckBox 420,70,110,14,"Country",.CheckBox2
CheckBox 420,84,100,14,"Region",.CheckBox3
CheckBox 420,98,110,14,"Language",.CheckBox4
CheckBox 420,112,100,14,"Browser",.CheckBox5
CheckBox 420,126,140,14,"Browser Version",.CheckBox6
CheckBox 420,140,150,14,"Operating System",.CheckBox7
CheckBox 420,154,120,14,"Screen Colors",.CheckBox8
CheckBox 420,168,110,14,"Page Path",.CheckBox9
CheckBox 420,182,180,14,"Is Mobile",.CheckBox10
CheckBox 600,56,150,14,"Network Domain",.CheckBox11
CheckBox 600,70,150,14,"Network Location",.CheckBox12
CheckBox 600,84,150,14,"User Defined Value",.CheckBox13
CheckBox 600,98,100,14,"Source",.CheckBox14
CheckBox 600,112,90,14,"Medium",.CheckBox15
CheckBox 600,126,90,14,"Keyword",.CheckBox16
CheckBox 600,140,100,14,"Campaign",.CheckBox17
CheckBox 600,154,110,14,"Ad Content",.CheckBox18
CheckBox 600,168,90,14,"Ad Group",.CheckBox19
CheckBox 600,182,90,14,"Ad Slot",.CheckBox20
GroupBox 30,161,270,126,"Enter dates in MM/DD/YYYY format:",.GroupBox3
TextBox 120,182,160,21,.TextBox1
Text 40,189,80,14,"Start Date:",.Text4
Text 40,224,80,14,"End Date:",.Text5
TextBox 120,224,160,21,.TextBox2
End Dialog
Dim dlg As UserDialog

'Process dialog selections
If Dialog (dlg) Then

Dim vProfileNumber As Variant
Dim vMetric As String
Dim sDimension As String
Dim sCFilter As String
Dim sGranularity As String
Dim lCounter As Long

'Get the profile number

If dlg.DropListBox1 <> -1 Then
vProfileNumber = sProfilesArray(dlg.DropListBox1,3)
Else
MsgBox CStr("Please select a valid profile.")
bRunProc = False
End If

'Formatting date
If IsDate(dlg.TextBox1) And IsDate(dlg.textbox2) Then
dStartDate = CDate(Format(dlg.TextBox1,"mm/dd/yyyy"))
dEndDate = CDate(Format(dlg.TextBox2, "mm/dd/yyyy"))
If dEndDate < dStartDate Then
MsgBox CStr("Please ensure that the end date does not occur earlier than the start date.")
bRunProc = False
End If
ElseIf IsDate(dlg.TextBox2) Then
If bRunProc Then MsgBox CStr("Please enter a start date value.")
bRunProc = False
ElseIf IsDate(dlg.TextBox1) Then
If bRunProc Then MsgBox CStr("Please enter an end date value.")
bRunProc = False
Else
If bRunProc Then MsgBox CStr("Please enter a start date and an end date.")
bRunProc = False
End If

If bRunProc Then

' Logic handling different dimensions/metrics posibilities; creates query information used to fetch XML data from Google Analytics
vMetric = LCase(sMetricsArray( dlg.DropListBox2))
sGranularity = LCase(sGranularityArray(dlg.DropListBox4))

sDimension = ""
lCounter = 0

If dlg.checkbox1 Then
lCounter = lCounter + 1
sDimension = sDimension & "&continent"
End If
If dlg.checkbox2 Then
lCounter = lCounter + 1
sDimension = sDimension & "&country"
End If
If dlg.checkbox3 Then
lCounter = lCounter + 1
sDimension = sDimension & "®ion"
End If
If dlg.checkbox4 Then
lCounter = lCounter + 1
sDimension = sDimension & "&language"
End If
If dlg.checkbox5 Then
lCounter = lCounter + 1
sDimension = sDimension & "&browser"
End If
If dlg.checkbox6 Then
lCounter = lCounter + 1
sDimension = sDimension & "&browserversion"
End If
If dlg.checkbox7 Then
lCounter = lCounter + 1
sDimension = sDimension & "&operatingsystem"
End If
If dlg.checkbox8 Then
lCounter = lCounter + 1
sDimension = sDimension & "&screencolors"
End If

     If dlg.checkbox9 Then
            sCFilter = "pagepath!=(other)"
            If vMetric = "timeonsite" Then vMetric = "timeonpage"
            If vMetric = "visits" Then vMetric = "uniquepageviews"
        Else
            sCFilter = ""
        End If

If dlg.CheckBox10 Then
lCounter = lCounter + 1
sDimension = sDimension & "&isMobile"

End If
If dlg.CheckBox11 Then
sDimension = sDimension & "&networkDomain"

End If

       If dlg.CheckBox12 Then
lCounter = lCounter + 1
sDimension = sDimension & "&networkLocation"
       End If

       If dlg.CheckBox13 Then
lCounter = lCounter + 1
sDimension = sDimension & "&userDefinedValue"
       End If

        If dlg.checkbox14 Then
        lCounter = lCounter + 1
        sDimension = sDimension & "&source"
        End If
If dlg.checkbox15 Then
lCounter = lCounter + 1
sDimension = sDimension & "&medium"
End If
If dlg.checkbox16 Then
sDimension = sDimension & "&keyword"
lCounter = lCounter + 1
End If
If dlg.checkbox17 Then
sDimension = sDimension & "&campaign"
lCounter = lCounter + 1
End If
If dlg.checkbox18 Then
sDimension = sDimension & "&adcontent"
lCounter = lCounter + 1
End If
If dlg.checkbox19 Then
sDimension = sDimension & "&adgroup"
lCounter = lCounter + 1
End If
If dlg.checkbox20 Then
sDimension = sDimension & "&adslot"
lCounter = lCounter + 1
End If

If lCounter > 6 Then
MsgBox ("Please select no more than 6 dimensions")
GoTo ReRunDialog
End If


' End Dimension/Metric handling

Dim V() As Variant

If Not GetGAdata(V(), sSessionToken, vProfileNumber, vMetric, dStartDate, dEndDate,sCFilter,"year&" & sGranularity  & sDimension, True,True) Then Exit All

Dim nVars As Long
Dim nCases As Long

nCases = UBound(V,1)
nVars = UBound(V,2)

Dim oSS As Spreadsheet
Set oSS = Spreadsheets.New


Dim i As Long
Dim j As Long
Dim sTempVarName As String

For i = 1 To nVars
sTempVarName = Trim(Replace(CStr(V(0,i)),"ga:",""))
oSS.VariableName(i) = UCase(Left(sTempVarName,1)) & Right(sTempVarName,Len(sTempVarName) - 1)
Next i

Dim data() As Variant
ReDim data(1 To nCases, 1 To nVars)
For i = 1 To UBound(V,1)
For j = LBound(V,2) To UBound(V,2)
data(i,j) = V(i,j)
Next j
Next i

'Return data to the output spreadsheet and display it to the user

oSS.Header = "Data returned for date range beginning on " & CStr(dStartDate) & " and ending on " & CStr(dEndDate) & "."

oSS.SetSize(nCases,nVars)
oSS.SetData(1,1, data)
oSS.AutoFitVariables (True)
oSS.EntireRange.AutoFit

Application.RouteOutput(oSS).Visible = True 'Outputs the spreadsheet containing the metrics/dimension data

End If

End If

Loop Until bRunProc

Exit Function

ErrFilterGADataDialog:

FilterGADataDialog = False

MsgBox CStr("Error encountered while retrieving desired metrics.  Procedure is closing." & vbCrLf & Err.Number & vbCrLf & Err.Description)

End Function

Private Function InitializeMetricsArray() As Boolean 'Creates metrics array values to present to the user in the function FilterGADataDialog

InitializeMetricsArray = True

On Error GoTo ErrIMR

sMetricsArray(0) ="Time On Site"
sMetricsArray(1) ="Visits"
sMetricsArray(2) ="Page Views"
sMetricsArray(3) ="Entrances"
sMetricsArray(4) ="Bounces"
sMetricsArray(5) ="New Visits"
sMetricsArray(6) = "Unique Page Views"

sMetricsArray(7) ="Goal 1 Completions"
sMetricsArray(8) ="Goal 2 Completions"
sMetricsArray(9) ="Goal 3 Completions"
sMetricsArray(10) ="Goal 4 Completions"
sMetricsArray(11) ="Goal 5 Completions"
sMetricsArray(12) ="Goal 6 Completions"

sMetricsArray(13) ="Transaction Revenue"
sMetricsArray(14) ="Item Revenue"

sMetricsArray(15) ="Search Depth"
sMetricsArray(16) ="Search Exits"
sMetricsArray(17) ="Search Uniques"
sMetricsArray(18) ="Search Visits"

Exit Function

ErrIMR:

InitializeMetricsArray = False

MsgBox CStr("Error encountered initializing metrics array.  Procedure is closing." & vbCrLf & Err.Number & vbCrLf & Err.Description)

End Function

Private Function InitializeGranularityArray() As Boolean 'Creates array of granularity choices to present to the user in the function FilterGADataDialog


InitializeGranularityArray = True

On Error GoTo ErrIGR

sGranularityArray(0) = "Week"
sGranularityArray(1) = "Month"

Exit Function

ErrIGR:

InitializeGranularityArray = False

MsgBox CStr("Error encountered initializing granular array.  Procedure is closing." & vbCrLf & Err.Number & vbCrLf & Err.Description)

End Function

Public Function GetGAProfiles(sAuthToken As String, Optional bIncludeHeaders As Boolean = False) As Variant

'Fetches a list of profiles for the authenticated user
'
'Input authentication token produced by the getGAauthenticationToken function
'The output is three columns wide; it includes account names, profile numbers and profile titles

    Dim sURL As String

    On Error GoTo ErrGetGAProfiles

    If sAuthToken = "Authentication failed" Then
GetGAProfiles = "Authentication failed"
        Exit Function
    End If

    sURL = "https://www.google.com/analytics/feeds/accounts/default?max-results=10000"
    Dim vObjhttp As Variant

    Set vObjhttp = CreateObject("MSXML2.ServerXMLHTTP")

    vObjhttp.Open "GET", sURL, False
    vObjhttp.setRequestHeader "Content-type", "application/x-www-form-urlencoded"
    vObjhttp.setRequestHeader "Authorization", "GoogleLogin Auth=" & sAuthToken
    vObjhttp.send ("")

    Dim sGAResponse As String
    sGAResponse = vObjhttp.responseText


    If InStr(1, sGAResponse, "Token invalid") > 0 Or InStr(1, sGAResponse, "Authorization required") > 0 Then
        GetGAProfiles = "Authentication failed"
        Exit Function
    End If

    Dim xmDoc As MSXML2.DOMDocument
    Dim xmnNode1 As MSXML2.IXMLDOMNode
    Dim xmnNode2 As MSXML2.IXMLDOMNode
    Dim xmlNodeList1 As MSXML2.IXMLDOMNodeList
    Dim xmnNode3 As MSXML2.IXMLDOMNode
    Dim xmlNodeList2 As MSXML2.IXMLDOMNodeList
    Dim xmmNamedMap As MSXML2.IXMLDOMNamedNodeMap
    Dim vTempArray() As Variant

    Set xmDoc = New MSXML2.DOMDocument

    xmDoc.loadXML (vObjhttp.responseText)

    Set xmnNode1 = xmDoc.documentElement

    Set xmlNodeList1 = xmnNode1.childNodes


    Dim lCntr As Long, lNodeCntr As Long

Dim sAccounts() As String

    lCntr = 1

    For Each xmnNode2 In xmlNodeList1

        If xmnNode2.nodeName = "openSearch:totalResults" Then

            lNodeCntr = CLng(xmnNode2.Text)

            If bIncludeHeaders Then
                ReDim vTempArray(0 To lNodeCntr, 1 To 3) As Variant
            Else
                ReDim vTempArray(1 To lNodeCntr, 1 To 3) As Variant
            End If
        End If

        If xmnNode2.nodeName = "entry" Then

            Set xmlNodeList2 = xmnNode2.childNodes

            For Each xmnNode2 In xmlNodeList2

                If xmnNode2.nodeName = "dxp:property" Then

                    Set xmmNamedMap = xmnNode2.attributes

                    If xmmNamedMap.getNamedItem("name").Text = "ga:accountName" Then
vTempArray(lCntr, 1) = xmmNamedMap.getNamedItem("value").Text

                    End If

                End If

                If xmnNode2.nodeName = "dxp:tableId" Then vTempArray(lCntr, 3) = CDbl(Replace(xmnNode2.Text, "ga:", ""))
                If xmnNode2.nodeName = "title" Then vTempArray(lCntr, 2) = xmnNode2.Text

            Next xmnNode2

            lCntr = lCntr + 1

        End If

    Next xmnNode2

    If bIncludeHeaders Then

        vTempArray(0, 1) = "Account Name"
        vTempArray(0, 3) = "Profile Number"
        vTempArray(0, 2) = "Profile Title"

    End If

GetGAProfiles = vTempArray

    Exit Function

ErrGetGAProfiles:

GetGAProfiles = "Fetching profiles failed"

End Function

Private Function getGAauthenticationToken(sEMail As String, sPassWord As String, sTheToken As String) As Boolean

'Fetches GA authentication token, which can then be used to fetch data with the function getGAdata function
'
On Error GoTo ErrGetGAAuthenticationToken

getGAauthenticationToken = True

    Dim lCurChr As Long
    Dim sTempAns As String

    Dim sAuthResponse As String
    Dim lAuthTokenStart As Long

    If sEMail = "" Then
        sTheToken = ""
        Exit Function
    End If

    If sPassWord = "" Then
        sTheToken = "Input password"
        Exit Function
    End If

        lCurChr = 1

        Do Until lCurChr - 1 = Len(sPassWord)
            Select Case Asc(Mid(sPassWord, lCurChr, 1))
                Case 48 To 57, 65 To 90, 97 To 122
                    sTempAns = sTempAns & Mid(sPassWord, lCurChr, 1)
                Case 32
                    sTempAns = sTempAns & "%" & Hex(32)
                Case Else
                    sTempAns = sTempAns & "%" & _
                              Format(Hex(Asc(Mid(sPassWord, _
                                                 lCurChr, 1))), "00")
            End Select

            lCurChr = lCurChr + 1
        Loop

        sPassWord = sTempAns

Dim vObjhttp

Dim sURL As String

    Set vObjhttp = CreateObject("MSXML2.ServerXMLHTTP")
    sURL = "https://www.google.com/accounts/ClientLogin"
    vObjhttp.Open "POST", sURL, False
    vObjhttp.setRequestHeader "Content-type", "application/x-www-form-urlencoded"
    vObjhttp.send ("accountType=GOOGLE&Email=" & sEMail & "&Passwd=" & sPassWord & "&service=analytics&Source=STATISTICA Data Import Tool")

    sAuthResponse = vObjhttp.responseText

    If InStr(1, sAuthResponse, "BadAuthentication") = 0 Then

     Dim sAuthToken

        lAuthTokenStart = InStr(1, sAuthResponse, "Auth=") + 4
        sAuthToken = Right(sAuthResponse, Len(sAuthResponse) - lAuthTokenStart)

        sTheToken = sAuthToken

    Else
MsgBox ("Authentication failed!")
End
    End If

    Exit Function

ErrGetGAAuthenticationToken:

getGAauthenticationToken = False

    MsgBox CStr("Errors encountered while authenticating e-mail address and password.  Application is closing." & _
vbCrLf & Err.Number & vbCrLf & Err.Description)

End Function

Private Function GetGAdata(V() As Variant, sAuthToken As String, vProfileNumber As Variant, sMetrics As String, dStartDate As Date, dEndDate As Date, Optional sFilters As String, Optional sDimensions As String, Optional bSort As Boolean = False, Optional bIncludeHeaders As Boolean = False, Optional bShowArraySize As Boolean = False) As Boolean

'Fetches data from the GA profile specified, using the authentication token generated by the getGAauthenticationToken function
'
'The profile number is displayed in your browser's URL when you're viewing a report in GA. It is not the web property ID which begins with UA.
'
'Possible values for "metrics" can be found at http://code.google.com/intl/en-EN/apis/analytics/docs/gdata/gdataReferenceDimensionsmetrics.html#metrics
'For example visits, visitors, pageviews, bounces, timeOnSite. Multiple metrics can be added using ampersands as separators
'
'Filters can be any dimensions from this list: http://code.google.com/intl/fi-FI/apis/analytics/docs/gdata/gdataReferenceDimensionsmetrics.html#dimensions
'For example to get a metric for new visitors only, use "visitorType==New Visitor"
'Multiple filters can be added; use semicolons for AND and commas for OR operators
'Detailed instructions are here: http://code.google.com/intl/en-EN/apis/analytics/docs/gdata/gdataReference.html#filtering
'
'Dimensions can be added to split the data. You can add up to 7 different dimension separated by ampersands.
'The query can fetch a maximum of 10000 rows.
'
'Setting the sort parameter as True sorts the data by the metrics column, in descending order
'
'Requires a reference to "Microsoft XML, v.6.0" (or other version; this is done in the VBA editor from Tools > References, find the reference from the list and select).

    On Error GoTo ErrGetGAData

    GetGAdata = True

    Dim vTempArray() As Variant

    Dim lCntr As Long
    Dim lNodeCntr As Long

    Dim dResultsCount As Double
    Dim dNodeListCount As Double

    Dim sStartDateString As String
    Dim sEndDateString As String


    If sAuthToken = "" Then
     GetGAdata = False
MsgBox "Authentication failed!"
End
    End If

    sStartDateString = Year(dStartDate) & "-" & Right("0" & Month(dStartDate), 2) & "-" & Right("0" & Day(dStartDate), 2)
    sEndDateString = Year(dEndDate) & "-" & Right("0" & Month(dEndDate), 2) & "-" & Right("0" & Day(dEndDate), 2)

    Dim sURL As String

    sURL = "https://www.google.com/analytics/feeds/data?ids=ga:" & vProfileNumber & "&start-date=" & sStartDateString & "&end-date=" & sEndDateString & "&max-results=10000"

    If sMetrics <> "" Then
     sMetrics = Replace(sMetrics," ","")
        If Left(sMetrics, 3) <> "ga:" Then sMetrics = "ga:" & sMetrics
        sMetrics = Replace(sMetrics, "&", "&ga:")
        sMetrics = Replace(sMetrics, "&ga:ga:", "&ga:")

        Dim sTempAns As String

        Dim lCurChr As Long

        sTempAns = ""

        lCurChr = 1

        Do Until lCurChr - 1 = Len(sMetrics)
            Select Case Asc(Mid(sMetrics, lCurChr, 1))
                Case 37, 48 To 57, 65 To 90, 97 To 122
                    sTempAns = sTempAns & Mid(sMetrics, lCurChr, 1)
                Case 32
                    sTempAns = sTempAns & "%" & Hex(32)
                Case Else
                    sTempAns = sTempAns & "%" & _
                              Format(Hex(Asc(Mid(sMetrics, _
                                                 lCurChr, 1))), "00")
            End Select

            lCurChr = lCurChr + 1
        Loop

        sMetrics = sTempAns
        sMetrics = Replace(sMetrics, "ga%00", "ga:")
        sMetrics = Replace(sMetrics, "%26", "%2C")

        sURL = sURL & "&metrics=" & sMetrics
    End If

    If sFilters <> "" Then
        If Left(sFilters, 3) <> "ga:" Then sFilters = "ga:" & sFilters
        sFilters = Replace(sFilters, ";", ";ga:")
        sFilters = Replace(sFilters, ";ga:ga:", ";ga:")
        sFilters = Replace(sFilters, ",", ",ga:")
        sFilters = Replace(sFilters, ",ga:ga:", ",ga:")

        sTempAns = ""

        lCurChr = 1

        Do Until lCurChr - 1 = Len(sFilters)
            Select Case Asc(Mid(sFilters, lCurChr, 1))
                Case 37, 42, 44, 46, 48 To 57, 59, 65 To 90, 97 To 122, 126
                    sTempAns = sTempAns & Mid(sFilters, lCurChr, 1)
                Case 32
                    sTempAns = sTempAns & "%" & Hex(32)
                Case Else
                    sTempAns = sTempAns & "%" & _
                              Format(Hex(Asc(Mid(sFilters, _
                                                 lCurChr, 1))), "00")
            End Select

            lCurChr = lCurChr + 1
        Loop

        sFilters = sTempAns
        sFilters = Replace(sFilters, "ga%00", "ga:")
        sFilters = Replace(sFilters, "%26", "%2C")

        sURL = sURL & "&filters=" & sFilters
    End If

    If sDimensions <> "" Then

        If Left(sDimensions, 3) <> "ga:" Then sDimensions = "ga:" & sDimensions

        sDimensions = Replace(sDimensions, "&", "&ga:")
        sDimensions = Replace(sDimensions, "&ga:ga:", "&ga:")

        sTempAns = ""

        lCurChr = 1

        Do Until lCurChr - 1 = Len(sDimensions)
            Select Case Asc(Mid(sDimensions, lCurChr, 1))
                Case 37, 48 To 57, 65 To 90, 97 To 122
                    sTempAns = sTempAns & Mid(sDimensions, lCurChr, 1)
                Case 32
                    sTempAns = sTempAns & "%" & Hex(32)
                Case Else
                    sTempAns = sTempAns & "%" & _
                              Format(Hex(Asc(Mid(sDimensions, _
                                                 lCurChr, 1))), "00")
            End Select

            lCurChr = lCurChr + 1
        Loop

        sDimensions = sTempAns
        sDimensions = Replace(sDimensions, "ga%00", "ga:")
        sDimensions = Replace(sDimensions, "%26", "%2C")

        sURL = sURL & "&dimensions=" & sDimensions
    End If

    If bSort Then sURL = sURL & "&bSort=-" & sMetrics

Dim vObjhttp

    Set vObjhttp = CreateObject("MSXML2.ServerXMLHTTP")

    vObjhttp.Open "GET", sURL, False
    vObjhttp.setRequestHeader "Content-type", "application/x-www-form-urlencoded"
    vObjhttp.setRequestHeader "Authorization", "GoogleLogin Auth=" & sAuthToken
    vObjhttp.send ("")

    Dim sGAResponse As String
    sGAResponse = vObjhttp.responseText

    If InStr(1, sGAResponse, "Token invalid") > 0 Or InStr(1, sGAResponse, "Authorization required") > 0 Then
     GetGAdata = False
        MsgBox "Authentication failed"
        End
    End If

    Dim xmDoc As MSXML2.DOMDocument
    Dim xmnNode1 As MSXML2.IXMLDOMNode
    Dim xmnNode2 As MSXML2.IXMLDOMNode
    Dim xmlNodeList1 As MSXML2.IXMLDOMNodeList
    Dim xmnNode3 As MSXML2.IXMLDOMNode
    Dim xmlNodeList2 As MSXML2.IXMLDOMNodeList
    Dim xmmNamedMap As MSXML2.IXMLDOMNamedNodeMap


    Set xmDoc = New MSXML2.DOMDocument

    xmDoc.loadXML (vObjhttp.responseText)

    Set xmnNode1 = xmDoc.documentElement

    Set xmlNodeList1 = xmnNode1.childNodes

     For Each xmnNode2 In xmlNodeList1

        If xmnNode2.nodeName = "openSearch:totalResults" Then

           dResultsCount = CDbl(xmnNode2.Text)

        End If

        If xmnNode2.nodeName = "entry" Then

            Set xmlNodeList2 = xmnNode2.childNodes

            For Each xmnNode2 In xmlNodeList2

                If xmnNode2.nodeName = "dxp:dimension" Or xmnNode2.nodeName = "dxp:metric" Then

                    dNodeListCount = dNodeListCount + 1

                End If

            Next xmnNode2

            Exit For

        End If

    Next xmnNode2

    If dResultsCount > 10000 Then dResultsCount = 10000

    If dResultsCount = 0 And dNodeListCount = 0 Then
     GetGAdata = False
        MsgBox "No data found"
        End
    End If

    ReDim vTempArray(1 To dResultsCount, 1 To dNodeListCount)

    If bIncludeHeaders Then ReDim vTempArray(0 To dResultsCount, 1 To dNodeListCount)

    If bShowArraySize Then
        ReDim vTempArray(1 To 1, 1 To 1)
        vTempArray(1, 1) = dNodeListCount & " columns * " & dResultsCount & " rows"
        If bIncludeHeaders Then vTempArray(1, 1) = vTempArray(1, 1) & " + header row"
        V() = vTempArray
        Exit Function
    End If

    lCntr = 1

    For Each xmnNode2 In xmlNodeList1

        If xmnNode2.nodeName = "entry" Then
            lNodeCntr = 1

            Set xmlNodeList2 = xmnNode2.childNodes

            For Each xmnNode2 In xmlNodeList2

                If xmnNode2.nodeName = "dxp:dimension" Then

                    Set xmmNamedMap = xmnNode2.attributes

                    vTempArray(lCntr, lNodeCntr) = Left(xmmNamedMap.getNamedItem("value").Text, 255)

                    If lCntr = 1 And bIncludeHeaders Then vTempArray(0, lNodeCntr) = xmmNamedMap.getNamedItem("name").Text

                    lNodeCntr = lNodeCntr + 1
                End If

                If xmnNode2.nodeName = "dxp:metric" Then

                    Set xmmNamedMap = xmnNode2.attributes

                    If Not IsNumeric(xmmNamedMap.getNamedItem("value").Text) Then

                        vTempArray(lCntr, lNodeCntr) = CDbl(Replace(xmmNamedMap.getNamedItem("value").Text, ".", ","))

                    Else

                        vTempArray(lCntr, lNodeCntr) = CDbl(xmmNamedMap.getNamedItem("value").Text)

                    End If

                    If lCntr = 1 And bIncludeHeaders Then vTempArray(0, lNodeCntr) = xmmNamedMap.getNamedItem("name").Text
                    lNodeCntr = lNodeCntr + 1

                End If

            Next xmnNode2

            lCntr = lCntr + 1

        End If

    Next xmnNode2

    V() = vTempArray

    Exit Function

ErrGetGAData:

GetGAdata = False

    If Not IsNumeric(vProfileNumber) Then
        MsgBox "Incorrect profile ID. You can see the correct ID from your browser's URL when you're viewing a report in GA."
       End
    Else
        MsgBox "Fetching data failed"
        End
    End If
End Function


____________________________
sincerely,
Elias Estatistics eu

15-05-2013 at 10:06 AM
View Profile Send Email to User Show All Posts | Quote Reply
AndreaVB Forum : Database : Data Type Mismatch - What does it mean..??
Previous Topic (Recordset \"LIKE\" filter of a number column)Next Topic (Restore Database Problem) New Topic New Poll Post Reply
Surf To:


Not Logged In? Username: Password: Lost your password?
borderAndreaVB free resources for Visual Basic developersborder
borderAndreaVB Visual Basic and VB.NET source code resources - Copyright © 1999-2014 Andrea Tincaniborder