Setting Data Link Unique Identifier with VBA code

[jik_ff]

Because I keep forgetting to set this when I start a new map file, which in turn messes up after the first database update (which means I have to re-link 30+ cells) I decided to have the main visio file set this once the initial Data Link is configured.  Unfortunately, it does not seem to be working.  Here's the code:

Code Select Expand


Private Sub GetDataLink(aShp As Visio.Shape)

    Dim accessStr As String
    Dim sqlSelect As String
    Dim filePath As String
    Dim offCode As String
    Dim aDRSet As Visio.DataRecordset
    Dim aKey() As String
   
    On Error Resume Next

    offCode = InputBox("Please Specify the 3 letter office code to set for this drawing.", "Set OfficeCode")
   
    'Make sure first that a valid 3 letter office code was entered (valid being 3 chars)
    If Len(offCode) <> 3 Then
        Debug.Print "Canceled"
        MsgBox "Operation Cancelled or Invalid Office Code specified : " & vbCrLf & UCase(offCode), vbOKOnly, "Operation Cancelled"
        'invalid code, skip to end of method
        GoTo EndThisCode
    End If
   
    ''*****************Old connection to local Access file***************************
    ''Path of support file should be the same as this file.
    'filepath = ThisDocument.Path + "FloorPlanDB2012.accdb"
    '
    ''initiate DataRecordset.Add from Access2007
    'accessStr = "Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;"
    ''Set the file and path info
    'accessStr = accessStr & "Data Source=" & filepath & ";"
    ''Bunch of commands that I don't understand, but are from a macro copy of the process
    'accessStr = accessStr & "Mode=Read;Extended Properties="""";Jet OLEDB:System database="""";"
    'accessStr = accessStr & "Jet OLEDB:Registry Path="""";Jet OLEDB:Engine Type=6;Jet OLEDB:Database Locking Mode=0;"
    'accessStr = accessStr & "Jet OLEDB:Global Partial Bulk Ops=2;Jet OLEDB:Global Bulk Transactions=1;"
    'accessStr = accessStr & "Jet OLEDB:New Database Password="""";Jet OLEDB:Create System Database=False;"
    'accessStr = accessStr & "Jet OLEDB:Encrypt Database=False;Jet OLEDB:Don't Copy Locale on Compact=False;"
    'accessStr = accessStr & "Jet OLEDB:Compact Without Replica Repair=False;Jet OLEDB:SFP=False;"
    '
    'sqlSelect = "SELECT * " _
    '        & "FROM [dbo_FloorPlan Query] " _
    '        & "WHERE [dbo_FloorPlan Query].LocCode = '" & offCode & "';"
    '
    ''*********************************************************************************
   
   
    '********new link straight to SQL server*******************************************
    accessStr = "Provider=SQLOLEDB.1;Integrated Security=SSPI;Persist Security Info=True;"
    accessStr = accessStr & "Initial Catalog=CNRFloorPlan;Data Source=Ontario;Use Procedure for Prepare=1;"
    accessStr = accessStr & "Auto Translate=True;Packet Size=4096;Workstation ID=TOR80000890S;"
    accessStr = accessStr & "Use Encryption for Data=False;Tag with column collation when possible=False"
   
    sqlSelect = "SELECT * " _
            & "FROM [SQLFloorPlanQuery] " _
            & "WHERE [SQLFloorPlanQuery].LocCode = '" & offCode & "';"
   
   
    'sqlSelect = "select * from ""CNRFloorPlan"".""dbo"".""SQLFloorPlanQuery"""
    '*********************************************************************************
   
    Application.ActiveDocument.DataRecordsets.Add accessStr, sqlSelect, 0, offCode & "-FloorPlanData"

    If InStr(1, Err.Description, "Unable to connect to the data") Then
        'Failed, give error explaination
        Dim errMessage As String
        errMessage = "File : " + vbCrLf + filePath + vbCrLf + "Cannot be located.  Please verify that the file is in the correct location."
        MsgBox errMessage, vbOKOnly, "ERROR: " + Err.Description
    Else
        'Check to make sure there is data that was imported.  Must have at least 1 Record!
        Dim recCount As Integer
        'only 1 record set should be in this document at this time!
        'grab the array of recordsets imported into recCount array.  Arrays start at 0, so add 1 for a proper count.
        recCount = UBound(ActiveDocument.DataRecordsets(1).GetDataRowIDs("")) + 1
        Debug.Print "Records count for office code "; UCase(offCode); " is "; recCount
       
        If recCount < 1 Then
            'Inform user of the error
            MsgBox UCase(offCode) & " Is not a valid office code, or no data exists for this office code in the database." _
            & "  Please make sure that data exists for this office code before continuing.", vbOKOnly, UCase(offCode) & " Does" _
            & " Not Exist"
            'remove the datalink as there is not data associated with it at this time
            ActiveDocument.DataRecordsets(1).Delete
        Else
            'Data does exist, continue on
            'set the Unique Identifier row automatically (since I keep forgetting) to "OfficeNumber"
            Set aDRSet = ActiveDocument.DataRecordsets(ActiveDocument.DataRecordsets.Count)
            aKey(0) = "OfficeNumber"
            aDRSet.SetPrimaryKey 2, aKey
            'Worked,Show the External Data Panel
            Application.ActiveWindow.Windows.ItemFromID(visWinIDExternalData).Visible = True
            'clean up excess shape objects
            Call CleanFirstPage(offCode)
            'bring in background map
            Call ImportMap
        End If
    End If
EndThisCode:
End Sub

I looked up and found the method Recordset.SetPrimaryKey and implemented it as such (so you don't have to read through all the code):

Code Select Expand

            'set the Unique Identifier row automatically (since I keep forgetting) to "OfficeNumber"
            Set aDRSet = ActiveDocument.DataRecordsets(ActiveDocument.DataRecordsets.Count)
            aKey(0) = "OfficeNumber"
            aDRSet.SetPrimaryKey 2, aKey


but it does not seem to be setting it (as when I check in the GUI it still shows it set to row order).  Just a bit of info, but the OfficeNumber column is not the primary key of the Table linked to.  I can set it in the GUI, but I want it to be done when the Drawing sets the Data Link, because I keep forgetting to do so (yes I can put in a prompt, but I would like it to run smoother incase others take over the usage of this drawing).

Thanks.

[jik_ff]

No one?

I added code to check (get instead of set) and it seems to be set to row count, and I don't seem to be able to change it. I even added the AutoNumber field (unique) to the import and tried setting it to that, but it still is set to Row count.  Has anyone gotten this to work?  (Visio Pro 2013)

[Yacine]

Hi, sorry but I could not follow your explanation.
Could reformulate your question?

[jik_ff]

Sure.

I have an SQL view that I use as the data source for the Linked Data in my visio diagram.  The actual Visio file is a template to store office layout info.  When I link the data, visio's default is to have the data's "Unique Identifier" set up as the order of the rows.  I believe this means that the first object will get the first row of data, and so on.  Unfortunately, when I am setting up the linked cells, it's difficult to order them exactly, due to the fun our Facilities team has with the numbering system.

That aside what I would normally do is when the data is linked, I would click on the DATA menu, Refresh Data... and Configure Refresh.  I would then set it to use the OfficeNumber as the Unique Identifier.  This way when ever I refreshed the data, it would sync up to the cell data based on that field (instead of the order the cells were placed)

According to MSDN (http://msdn.microsoft.com/en-us/library/office/ff766529(v=office.15).aspx) You can use the DataRecordset.SetPrimaryKey Method to set this, but for the life of me, I cannot get it to work...

[Yacine]

If I remember correctly, the database wizard asks you to identify an ID column.
If you haven't stumbled over this question, should I assume, that you connect directly via code?

[jik_ff]

I guess I should have stated that too.  Basically I have put quite a bit of code in the background of the visio file so that other operators of the file (to manage thier respective offices) did not have to worry about linking the data (which is populated by an Access database front end).

So basically all they have to do is type in thier office code and the VBA does the rest... almost...  Again, I don't want to have to worry about forgetting this step again...  I could put in yet another Message Box indicating how to set this manually, but if the VBA code can do it, then all the better...

<EDIT>
To add to the confussion, I went into one of the other office files that I had manually set (through configure refresh) the primary key and added a bit of code to check the primary key (DataRecordset.GetPrimaryKey). When I output the values (debug.print) they came back as what I set (type = 2, key field = "OfficeNumber").  So I am on the right path, but I am not sure why it will not let me set it through VBA with the commands that they provide...
(another area of the MSDN that talks about using SetPrimaryKey : http://msdn.microsoft.com/en-us/library/office/ff766177(v=office.15).aspx#sectionSection13)

[Thomas Winkel]

I guess that the problem is the error handling with On Error Resume Next over the whole code.
So you will never find your programming errors.
In your code you did not define the size of the aKey array.
Thus your code will crash here: aKey(0) = "OfficeNumber"
But you will not mention, because at the first sight everything seems to be OK (the data has been linked).

However, the following minimal code (for an existing dataRecordSet) is working here:

Code Select Expand


Sub setKey()
    Dim aDRSet As Visio.DataRecordset
    Dim aKey(1 To 1) As String
   
    Set aDRSet = ActiveDocument.DataRecordsets(ActiveDocument.DataRecordsets.Count)
    aKey(1) = "OfficeNumber"
    aDRSet.SetPrimaryKey VisPrimaryKeySettings.visKeySingle, aKey
End Sub


[jik_ff]

That is interesting Thomas, thoguh I did copy the code snipit I used pretty much straight from the first MSDN link.  They did not define the array size.  Also, when I ran the test on an office file that I had manually set the unique identifier, I did not define the array size there, and it worked.  So I put in a debug print for the error description, and it comes back with TYPE MISMATCH (error 13).

Now I am more confused (also, I added the definition of the array length and had it use the 1th element).  Here is the current bit of code in question:

Code Select Expand

            'Data does exist, continue on
            'set the Unique Identifier row automatically (since I keep forgetting) to "OfficeNumber"
            Set aDRSet = ActiveDocument.DataRecordsets(ActiveDocument.DataRecordsets.Count)
           
            Debug.Print Err.Description
            aDRSet.GetPrimaryKey oType, oKey
           
            Debug.Print "----------------------"
            Debug.Print oType
            Debug.Print oKey(1)
            Debug.Print Err.Description
            Debug.Print Err.Number
           
           
            aKey(1) = "AutoNumber"
            aDRSet.SetPrimaryKey VisPrimaryKeySettings.visKeySingle, aKey
            aDRSet.GetPrimaryKey oType, oKey
           
            Debug.Print "----------------------"
            Debug.Print oType
            Debug.Print oKey(1)
            Debug.Print Err.Description

The debug output looks like this:

Code Select Expand


----------------------
0

Type mismatch
13
----------------------
0

Type mismatch



There is no error prior to the GetPrimaryKey line, so it has to be something there....

[Thomas Winkel]

The original Microsoft Code from your link above does not work here.
It crashes with "Run-time error '9': Subscript out of range" at aPrimaryKeyColumns(0) = "columnName"
It makes no difference whether Option Explicit is set or not. It crashes.
As soon as I specify the array length (Dim aPrimaryKeyColumns(0 To 0) As String) it works.

Did you try my minimal example?
Maybe there are more hidden errors in your code.
Please be careful with On Error Resume Next, especially during development.
It's hard to find errors (or even realize them) with this option enabled.

[jik_ff]

You may be on to something there with the on error resume.  I tried you code as well, it gave the same error.

I tried turning off the error skip (goto 0) and funny the code does not run.  No error, it just doesn't run.  Should I not get some kind of error?

[jik_ff]

OK, I seperated it out and now have an independant call for this:

Code Select Expand

Private Sub SetIdentifier()
    'set the Unique Identifier row automatically (since I keep forgetting) to "OfficeNumber"
           
    On Error GoTo ErrHandler
           
    Dim vsoDataRecordset As Visio.DataRecordset
    Dim intCount As Integer
    Dim aPrimaryKeyColumns(1 To 1) As String
     
    intCount = ThisDocument.DataRecordsets.Count
    aPrimaryKeyColumns(1) = "OfficeNumber"
    Set vsoDataRecordset = ThisDocument.DataRecordsets(intCount)
    vsoDataRecordset.SetPrimaryKey visKeySingle, aPrimaryKeyColumns
   
    Debug.Print Err.Number
    Debug.Print Err.Description
    Debug.Print Err.HelpFile

'    Dim vsoDataRecordset As Visio.DataRecordset
'    Dim intCount As Integer
'    Dim astrPrimaryKeyColumns() As String
    Dim vsoKeySettings As VisPrimaryKeySettings

    MsgBox "U.ID should be set...."

    intCount = ThisDocument.DataRecordsets.Count
    Set vsoDataRecordset = ThisDocument.DataRecordsets(intCount)
    vsoDataRecordset.GetPrimaryKey vsoKeySettings, aPrimaryKeyColumns

    If vsoKeySettings = visKeyRowOrder Then
        Debug.Print vsoKeySettings, "No primary key"
    Else
        Debug.Print vsoKeySettings, aPrimaryKeyColumns(1)
    End If

    MsgBox "Was U.ID set???"

    Exit Sub
   
ErrHandler:
    MsgBox Err & ": " & Error(Err)

End Sub

I have added your suggestion for the arrays (1 to 1).  I run the code, and I get back error 13 : Type Mismatch.

[Thomas Winkel]

Hi,

GetPrimaryKey still requires an unspecified string array:
Dim anOtherPrimaryKeyColumns() As String

Regards,
Thomas

[jik_ff]

Damn shortcutting...

You are right.  I was using a defined array in the Get command when doing my checks, which caused the fail.

It is working now.  Thanks again for your time and patience, Thomas.