Option Explicit

' Common Dialog constants

Global Const PD_NOPAGENUMS = &H8&
Global Const PD_NOSELECTION = &H4&
Global Const PD_USEDEVMODECOPIES = &H40000

Global Const OFN_CREATEPROMPT = &H2000&
Global Const OFN_OVERWRITEPROMPT = &H2&
Global Const OFN_PATHMUSTEXIST = &H800&
Global Const OFN_HIDEREADONLY = &H4&


' Message Box Constants

Global Const MB_OKCANCEL = 1
Global Const MB_ABORTRETRYIGNORE = 2
Global Const MB_YESNOCANCEL = 3
Global Const MB_YESNO = 4
Global Const MB_RETRYCANCEL = 5

Global Const MB_ICONSTOP = 16
Global Const MB_ICONQUESTION = 32
Global Const MB_ICONEXCLAMATION = 48
Global Const MB_ICONINFORMATION = 64

' Column constants

Global Const IDX_LOW = 1
Global Const IDX_NAME = 1
Global Const IDX_VALUE = 2
Global Const IDX_DEFVALUE = 3
Global Const IDX_PROMPT = 4
Global Const IDX_HIGH = 4

Global m_db As Object
Global m_iAttribCount As Integer
Global m_strAttribs() As String
Global g_fEdit As Integer

' WINDOWS.H constants and declarations
'
Global Const HWND_TOPMOST = -1
Global Const HWND_NOTOPMOST = -2
Global Const SWP_NOACTIVATE = &H10
Global Const SWP_SHOWWINDOW = &H40
Global Const SWP_NOSIZE = &H1
Global Const SWP_NOMOVE = &H2

Declare Sub SetWindowPos Lib "User" (ByVal hWnd As Integer, ByVal hWndInsertAfter As Integer, ByVal x As Integer, ByVal y As Integer, ByVal cx As Integer, ByVal cy As Integer, ByVal wFlags As Integer)

Type ATTRIB
    strName As String
    strValue As String
    strDefValue As String
    strPrompt As String
End Type


' Output location constants

Global Const OUT_INVAL% = 0
Global Const OUT_CLIPBOARD% = 1
Global Const OUT_FILE% = 2

' Export Types

Global Const EXPTYPE_INVAL = 0
Global Const EXPTYPE_ALL = 1
Global Const EXPTYPE_SELECTION = 2
Global Const EXPTYPE_CURRENT = 3

' Module globals for export

Dim m_iFile As Integer
Dim m_strBuf As String
Global g_iWhere As Integer
Global g_iExportType As Integer

Function AttribCount ()
' Just a nice function for returning the attribute count so people
' don't go messing with how we store the count

    AttribCount = m_iAttribCount
End Function

Sub CloseOutputBuffer ()
' Closes the output mechanism we were using for exporting attributes

    Select Case g_iWhere
        Case OUT_FILE:
            Close m_iFile

            m_iFile = 0
        Case OUT_CLIPBOARD
            Clipboard.Clear
            Clipboard.SetText m_strBuf
    
            m_strBuf = ""
    End Select
End Sub

Function ExportAttribs () As Integer
    On Error GoTo lblExportAttribsExit

    ReDim strAttribNames(1 To 400) As String
    Dim iAttribCount As Integer
    Dim Shapes As Object
    Dim Shape As Object
    Dim db As Object
    Dim Attribs As Object
    Dim theAttrib As Object
    Dim I As Integer
    Dim J As Integer
    Dim iSelCount As Integer
    Dim iAttrib As Integer
    Dim strAttribName As String
    Dim strRec As String
    Dim fRetVal As Integer

    Const REC = ASC_TAB
    fRetVal = False
    
    If Not m_db Is Nothing Then m_db.BeginTransaction

    If vaoGetVisio(True, False) <> visGet Then
        Exit Function
    End If

    ' There's a trick here.  If the user wants to export the selection but
    ' there's only one shape in it then we just use the global m_db.  The
    ' case below needs to know about this special case so we change the

    iSelCount = g_appVisio.ActiveWindow.Selection.Count

    If g_iExportType = EXPTYPE_SELECTION Then
        If iSelCount = 0 Then
            MsgBox "No shapes selected", MB_ICONSTOP, "Error"
            fRetVal = True
            GoTo lblExportAttribsExit
        End If

        If iSelCount = 1 And Not (m_db Is Nothing) Then
            g_iExportType = EXPTYPE_CURRENT
        End If
    End If
    
    ' First we have to build up our list of attribute names

    Select Case g_iExportType
        Case EXPTYPE_ALL, EXPTYPE_SELECTION:
            ' We're working on collections here

            If EXPTYPE_ALL = g_iExportType Then
                Set Shapes = g_appVisio.ActivePage.Shapes
            Else
                Set Shapes = g_appVisio.ActiveWindow.Selection
            End If

            For I = 1 To Shapes.Count
                Set Shape = Shapes(I)
                Set db = CreateObject("Visio.ShapeDatabase")
                db.PutShape Shape
                db.BeginTransaction

                Set Attribs = db.Attributes

                For iAttrib = 1 To Attribs.Count
                    strAttribName = Attribs(iAttrib).Name

                    For J = 1 To iAttribCount
                        If strAttribNames(J) = strAttribName Then
                            strAttribName = ""
                            Exit For
                        End If
                    Next J

                    If strAttribName <> "" Then
                        iAttribCount = iAttribCount + 1

                        If iAttribCount >= UBound(strAttribNames) Then
                            MsgBox "Out of memory"
                            Exit Function
                        End If

                        strAttribNames(iAttribCount) = strAttribName
                    End If
                Next iAttrib
            Next I
        Case EXPTYPE_CURRENT:
            ' In this case we don't have to do much more than dump the grid
            ' to our export buffers

            Set Attribs = m_db.Attributes

            ' Create Table Header

            strRec = FormatStringANSI("Shape Name")

            For I = 1 To Attribs.Count
                strRec = strRec & Chr(REC) & FormatStringANSI(Attribs(I).Name)
            Next I

            If Not WriteRecord(strRec) Then GoTo lblExportAttribsExit

            ' Write Attribute Data

            strRec = FormatStringANSI(m_db.Shape.Name)

            For I = 1 To Attribs.Count
                strRec = strRec & Chr(REC) & FormatStringANSI(Attribs(I).Value)
            Next I
            
            If Not WriteRecord(strRec) Then GoTo lblExportAttribsExit

            fRetVal = True
            GoTo lblExportAttribsExit
        Case Else
            GoTo lblExportAttribsExit
    End Select

    ' If there weren't any attributes then we exit

    If 0 = iAttribCount Then
        MsgBox "No Attribute data found.", MB_ICONSTOP, "Error"
        fRetVal = True
        GoTo lblExportAttribsExit
    End If

    ' Now it's time to write the data out.  Remember, at this pointer we are
    ' supposed to be working on some sort of collection object set earlier.

    ' Export Table Header
    strRec = FormatStringANSI("Shape Name")

    For iAttrib = 1 To iAttribCount
        strRec = strRec & Chr(REC) & strAttribNames(iAttrib)
    Next iAttrib

    If Not WriteRecord(strRec) Then GoTo lblExportAttribsExit
    strRec = ""

    ' Export Table Body

    For I = 1 To Shapes.Count
        Set Shape = Shapes(I)
        Set db = CreateObject("Visio.ShapeDatabase")
        db.PutShape Shape
        Set Attribs = db.Attributes

        strRec = FormatStringANSI(Shape.Name)

        For iAttrib = 1 To iAttribCount
            On Error GoTo lblCatch
            Set theAttrib = Nothing
            Set theAttrib = Attribs(strAttribNames(iAttrib))
            On Error GoTo lblExportAttribsExit

            If Not (theAttrib Is Nothing) Then
                strRec = strRec & Chr(REC) & FormatStringANSI(theAttrib.Value)
            Else
                strRec = strRec & Chr(REC)
            End If
        Next iAttrib

        If Not WriteRecord(strRec) Then GoTo lblExportAttribsExit
        strRec = ""
    Next I

    fRetVal = True

lblExportAttribsExit:
    If Not m_db Is Nothing Then m_db.EndTransaction
    ExportAttribs = fRetVal
    Exit Function
lblCatch:
    Resume Next
End Function

Function GetCurrentAttrib (theAttrib As ATTRIB) As Integer
' Retrieves the current attribute from the grid and stores it in a user
' supplied buffer.  Used during editing.  Returns True if an attribute was
' selected, otherwise False.

    Dim iOldCol As Integer
    
    ' Make sure we've got some attributes first

    If AttribCount() <= 0 Then
        GetCurrentAttrib = False
        Exit Function
    End If

    ' Store the last grid column

    iOldCol = frmMain.ctlGrid.Col

    ' Fill out the data structure

    frmMain.ctlGrid.Col = IDX_NAME
    theAttrib.strName = frmMain.ctlGrid.Text
    frmMain.ctlGrid.Col = IDX_VALUE
    theAttrib.strValue = frmMain.ctlGrid.Text
    frmMain.ctlGrid.Col = IDX_DEFVALUE
    theAttrib.strDefValue = frmMain.ctlGrid.Text
    frmMain.ctlGrid.Col = IDX_PROMPT
    theAttrib.strPrompt = frmMain.ctlGrid.Text

    ' Restore the last column

    frmMain.ctlGrid.Col = iOldCol

    GetCurrentAttrib = True
End Function

Function min (ByVal x, ByVal y)
    If x <= y Then
        min = x
    Else
        min = y
    End If
End Function

Function OpenOutputBuffer (strFile As String) As Integer
' Opens and initializes the output buffer for exporting.

    On Error GoTo lblOpenBufferErr

    Dim iFile As Integer
    Dim fRetVal As Integer

    fRetVal = False

    ' Next we initialize depending upon the export destination

    Select Case g_iWhere
        Case OUT_FILE:
            iFile = FreeFile

            Open strFile For Output As iFile

            m_iFile = iFile
            fRetVal = True
        Case OUT_CLIPBOARD:
            m_strBuf = ""
            fRetVal = True
        Case Else
            fRetVal = False
    End Select

    OpenOutputBuffer = fRetVal
    Exit Function

lblOpenBufferErr:
    OpenOutputBuffer = False
    m_iFile = 0
    Exit Function
End Function

Sub RefreshAll ()
' Handles refreshing the grid by getting the selected shape in Visio,
' creating a Shape database for it and displaying all its Attribute data
' in the grid.

    On Error GoTo lblRefreshAllErr
    
    Dim I As Integer
    Dim shp As Object
    Dim Attribs As Object

    ' Release the global Attributes collection

    Set m_db = Nothing
    
    frmMain.cmdEdit.Enabled = False
    frmMain.cmdAdd.Enabled = False
    frmMain.cmdDelete.Enabled = False

    ' Try and get Visio - it must be running!
    
    If vaoGetVisio(True, False) <> visGet Then
        MsgBox "Visio must be running."
        Exit Sub
    End If

    ' Check Visio version
    If g_appVisio.Version < 2 Then
        MsgBox "Requires Visio 2.0 or greater."
        End
    End If

    ' See if there is a selected shape

    On Error GoTo lblRefreshErr2
    Set shp = g_appVisio.ActiveWindow.Selection(1)
    On Error GoTo lblRefreshAllErr

    ' Create the shape database

    On Error GoTo lblRefreshErr3
    Set m_db = CreateObject("Visio.ShapeDatabase")
    On Error GoTo lblRefreshAllErr

    ' Initialize the database and do a BeginTransaction because all we're
    ' gonna do is read in the attributes.  This should speed things up
    ' quite a bit.

    m_db.PutShape shp
    m_db.BeginTransaction

    frmMain.cmdAdd.Enabled = True

    Set Attribs = m_db.Attributes
    m_iAttribCount = Attribs.Count
    
    ' Read in the attribute data to a local data strucutre

    If 0 <> AttribCount() Then
        frmMain.cmdEdit.Enabled = True
        frmMain.cmdDelete.Enabled = True

        ReDim m_strAttribs(IDX_LOW To IDX_HIGH, 1 To m_iAttribCount)
    
        For I = 1 To m_iAttribCount
            m_strAttribs(IDX_NAME, I) = Attribs(I).Name
            m_strAttribs(IDX_VALUE, I) = Attribs(I).Value
            m_strAttribs(IDX_DEFVALUE, I) = Attribs(I).DefaultValue
            m_strAttribs(IDX_PROMPT, I) = Attribs(I).Prompt
        Next I
    End If

    ' End the transaction and refresh the grid itself

    m_db.EndTransaction
    RefreshGrid

    Exit Sub

lblRefreshAllErr:
    MsgBox "Error Refreshing."
    Exit Sub

lblRefreshErr2:
    MsgBox "A shape must be selected."
    Exit Sub

lblRefreshErr3:
    MsgBox "Error creating Shape Database."
    End
End Sub

Sub RefreshGrid ()
' Handles taking the Attribute data from our internal data structures and
' displaying it in the grid.  Nicely clears the grid and sizes the columns
' for us as well


    Dim iCol As Integer
    Dim iRow As Integer

    ' Always clear the grid first

    ClearGrid frmMain.ctlGrid

    ' If not Attributes we just exit

    If AttribCount() < 1 Then Exit Sub
    
    ' Set up the grid rows - remember the column title row!

    frmMain.ctlGrid.Rows = AttribCount() + 1

    ' Fill in the grid

    For iRow = 1 To m_iAttribCount
        frmMain.ctlGrid.Row = iRow

        frmMain.ctlGrid.Col = 0
        frmMain.ctlGrid.Text = iRow

        For iCol = IDX_LOW To IDX_HIGH
            frmMain.ctlGrid.Col = iCol
            frmMain.ctlGrid.Text = m_strAttribs(iCol, iRow)
        Next iCol
    Next iRow
    
    ' Fit the columns

    FitColumn frmMain.ctlGrid, 0

    For iCol = IDX_LOW To IDX_HIGH
        FitColumn frmMain.ctlGrid, iCol
    Next iCol

    ' Fit the rows for those hard to manage attributes

    For iRow = 0 To frmMain.ctlGrid.Rows - 1
        FitRow frmMain.ctlGrid, iRow
    Next iRow

    frmMain.ctlGrid.Col = 1
    frmMain.ctlGrid.Row = 1
    frmMain.ctlGrid.SelStartRow = 1
    frmMain.ctlGrid.SelStartCol = 1
    frmMain.ctlGrid.SelEndRow = 1
    frmMain.ctlGrid.SelEndCol = 1
End Sub

Function WriteRecord (strRecord As String) As Integer
' Writes a record to the output file

    On Error GoTo lblWriteRecord

    Dim strEOL As String
    Dim fRetVal As Integer

    fRetVal = False
    strEOL = Chr(13) + Chr(10)

    Select Case g_iWhere
        Case OUT_FILE:
            Print #m_iFile, strRecord; strEOL;
        Case OUT_CLIPBOARD:
            m_strBuf = m_strBuf & strRecord & strEOL
    End Select

    fRetVal = True

lblWriteRecord:
    WriteRecord = fRetVal
    Exit Function
End Function

