Visio URLs

artmg · Mar 16, 2015 · d244a16 · d244a16
1 parent 02b8e35
commit d244a16
Show file tree

Hide file tree

Showing 6 changed files with 307 additions and 28 deletions.
diff --git a/Closed.txt.txt b/Closed.txt.txt
@@ -2,3 +2,9 @@ The following modules must remain closed source:
 
 mod_exc_FileLocations
 
+
+These have also been checked to extract any generic code of potential value:
+
+mod_acc_ImportBank
+
+
diff --git a/mod_off_ExportListToExcel.bas b/mod_off_ExportListToExcel.bas
@@ -1,6 +1,7 @@
 Attribute VB_Name = "mod_off_ExportListToExcel"
 ' mod_off_ExportListToExcel
-' 150303.AMG
+' 150316.AMG  debug pointer issue
+' 150303.AMG  created
 
 ' References
 ' ==========
@@ -19,6 +20,7 @@ Function ExcelOutputCreateWorksheet()
     Dim wbk As Excel.Workbook
     Set wbk = Excel.Application.Workbooks.Add
     Set shtOut = wbk.Worksheets(1)
+
     lngNextRow = 1
     lngNextCol = 1
 End Function
@@ -31,5 +33,10 @@ End Function
 
 Function ExcelOutputWriteValue(val As Variant)
     shtOut.Cells(lngNextRow, lngNextCol).Value = val
+    lngNextCol = lngNextCol + 1
 End Function
 
+Function ExcelOutputShow()
+    shtOut.Activate
+'    Excel.Application.ActivateMicrosoftApp
+End Function
diff --git a/mod_off_FilesFoldersSitesLinks.bas b/mod_off_FilesFoldersSitesLinks.bas
@@ -7,6 +7,7 @@ Const cStrModuleName As String = "mod_off_FilesFoldersSitesLinks"
 ' generic functions for manipulating filesystem objects
 ' and web and sharepoint sites and URLs
 '
+'  150316.AMG  added recursion into subfolders
 '  150304.AMG  renamed from mod_exc_FilesFoldersSitesLinks as actually generic
 '  150219.AMG  added GetURL for hyperlinks
 '  150219.AMG  cribbed from other VBA modules - NB: not ALL functions have been tested since cribbing!
@@ -20,6 +21,8 @@ Const cStrModuleName As String = "mod_off_FilesFoldersSitesLinks"
 ' Scripting = Microsoft Scripting Runtime (C:\Windows\SysWOW64\scrrun.dll) {420B2830-E718-11CF-893D-00A0C9054228}
 ' MSXML2 = Microsoft XML, v6.0 (C:\WINDOWS\System32\msxml6.dll) {F5078F18-C551-11D3-89B9-0000F81FE221}
 
+' kludge for apps without Application.PathSeparator
+Const cStrPathSeparator = "\"
 
 Const cStrExcFileFilter As String = "Excel Workbooks, *.xls; *.xlsx"
 '        Case "xls": strFilter = "Excel Workbooks (*.xls), *.xls"
@@ -47,9 +50,9 @@ Private Declare Function URLDownloadToFile Lib "urlmon" Alias _
 
 ' was mod_acc_ImportBank.bas!JustFileName 060131.AMG
 ' Look for the last backslash and return just the characters following it
-Private Function JustFileName(FullPath As Variant)
+Public Function JustFileName(FullPath As Variant)
     Dim LastBackslash As Long
-    LastBackslash = InStrRev(FullPath, "\")
+    LastBackslash = InStrRev(FullPath, cStrPathSeparator)
     If LastBackslash > 1 Then
         JustFileName = Mid(FullPath, LastBackslash + 1)
     Else
@@ -59,12 +62,12 @@ End Function
 
 
 ' was mod_exc_SchemaReader.bas GetFolderFromFileName 071030.AMG
-Function GetFolderFromFileName(FileName As String) As String
+Public Function GetFolderFromFileName(FileName As String) As String
 ' Folder Name extraction routine loosely based on code from ExcelTip.com (Function FileOrFolderName)
     Dim Position As Integer
     Position = 0
-    While InStr(Position + 1, FileName, Application.PathSeparator) > 0
-        Position = InStr(Position + 1, FileName, Application.PathSeparator)
+    While InStr(Position + 1, FileName, cStrPathSeparator) > 0
+        Position = InStr(Position + 1, FileName, cStrPathSeparator)
     Wend
     If Position = 0 Then
         GetFolderFromFileName = CurDir
@@ -114,6 +117,8 @@ Function strFolderChosenByUser(strTitle As String) As String
 ' we just need the folder name really
 ' SourceFilename = dlg.Execute
 
+    ' value if none chosen is empty string
+    strFolderChosenByUser = ""
     If dlg.Show Then
         ' credit http://www.mrexcel.com/forum/excel-questions/737619-visual-basic-applications-get-folder-path-using-msofiledialogfolderpicker.html
         strFolderChosenByUser = dlg.SelectedItems(1)
@@ -135,44 +140,75 @@ Function arrFilteredPathnamesInUserTree( _
 ' this will return an array of full file and path names to files meeting a filter criteria
 ' using FileSystemObject from Shell Scripting
 ' in a folder chosen by the user
+' or if none found then returnString(0)=""
 
     Dim strArrReturn() As String
     Dim intElement As Integer
     Dim SourceFilename As String
-    Dim SourceFolderName As String
+    Dim strFolderName As String
 
-    SourceFolderName = strFolderChosenByUser("Please choose a folder")
+    intElement = 0
+    ReDim strArrReturn(0)
+    ' default value if none found
+    strArrReturn(0) = ""
 
-    '
-    Dim fso As Scripting.FileSystemObject
-    Dim SourceFolder As Scripting.folder
-    Dim SourceFile As Scripting.file
-    Set fso = New Scripting.FileSystemObject
+    strFolderName = strFolderChosenByUser("Please choose a folder")
 
-    ' assuuming strFilter is single element but delimited (e.g. ; or | ), break it into array for easier match looping
+    If strFolderName <> "" Then
 
-    Set SourceFolder = fso.GetFolder(SourceFolderName)
-    'Application.ScreenUpdating = False
-    intElement = 0
+        ' assuuming strFilter is single element but delimited (e.g. ; or | ), break it into array for easier match looping
+
+        ' first add the current
+        AddMatchingNamesFromFolderToArray strArrReturn, strFolderName, strFilter, intElement
+
+        If bRecurse Then ' do tree not just folder
+            Dim fso As Scripting.FileSystemObject
+            Dim fsoFolder As Scripting.folder
+            Dim fsoSubFolder As Scripting.folder
+
+            Set fso = New Scripting.FileSystemObject
+            Set fsoFolder = fso.GetFolder(strFolderName)
+            'Application.ScreenUpdating = False
+
+            For Each fsoSubFolder In fsoFolder.SubFolders
+                AddMatchingNamesFromFolderToArray strArrReturn, fsoSubFolder.Path, strFilter, intElement
+            Next fsoSubFolder
+        End If
+    End If
 
-    ' if bRecurse then do tree not just folder
-    For Each SourceFile In SourceFolder.Files
+    arrFilteredPathnamesInUserTree = strArrReturn
+End Function
 
 
+Function AddMatchingNamesFromFolderToArray(strArray() As String, strFolderName As String, strFilter As String, intElement As Integer)
+    Dim fso As Scripting.FileSystemObject
+    Dim fsoFolder As Scripting.folder
+    Dim fsoFile As Scripting.file
+    Set fso = New Scripting.FileSystemObject
+
+    Set fsoFolder = fso.GetFolder(strFolderName)
+
+    For Each fsoFile In fsoFolder.files
+
         ' check against each of the filters in the array
         ' ONLY DOES ONE for the moment
-        If LCase(Right(SourceFile.Name, Len(strFilter))) = LCase(strFilter) Then
+        If LCase(Right(fsoFile.Name, Len(strFilter))) = LCase(strFilter) Then
 
             ' as redimming each item affects performance,
             ' consider doing it say 10 or 100 at a time then shrinking at the end
-            ReDim Preserve strArrReturn(intElement)
+            ReDim Preserve strArray(intElement)
 
-            strArrReturn(intElement) = SourceFolderName & Application.PathSeparator & SourceFile.Name
+            strArray(intElement) = strFolderName & cStrPathSeparator & fsoFile.Name
             intElement = intElement + 1
         End If
-    Next SourceFile
+    Next fsoFile
+
+End Function
 
 
+' from mod_exc_FileLocations FindParentFolderFromPath 130828.AMG
+Function FindParentFolderFromPath(strFullPath As String, Optional theSlash As String = "\") As String
+    FindParentFolderFromPath = Left(strFullPath, InStrRev(strFullPath, theSlash) - 1)
 End Function
 
 
@@ -213,3 +249,97 @@ End Function
 
 
 
+
+
+''''''''''''''
+' Credit > http://allenbrowne.com/ser-59.html
+' Alternatives > http://my.advisor.com/doc/16279
+'
+''' START OF COPIED CODE ''''''''''''''''''''''''''''
+'
+'
+Public Function ListFiles(strPath As String, Optional strFileSpec As String, _
+    Optional bIncludeSubfolders As Boolean, Optional lst As ListBox)
+On Error GoTo Err_Handler
+    'Purpose:   List the files in the path.
+    'Arguments: strPath = the path to search.
+    '           strFileSpec = "*.*" unless you specify differently.
+    '           bIncludeSubfolders: If True, returns results from subdirectories of strPath as well.
+    '           lst: if you pass in a list box, items are added to it. If not, files are listed to immediate window.
+    '               The list box must have its Row Source Type property set to Value List.
+    'Method:    FilDir() adds items to a collection, calling itself recursively for subfolders.
+    Dim colDirList As New Collection
+    Dim varItem As Variant
+
+    Call FillDir(colDirList, strPath, strFileSpec, bIncludeSubfolders)
+
+    'Add the files to a list box if one was passed in. Otherwise list to the Immediate Window.
+    If lst Is Nothing Then
+        For Each varItem In colDirList
+            Debug.Print varItem
+        Next
+    Else
+        For Each varItem In colDirList
+        lst.AddItem varItem
+        Next
+    End If
+
+Exit_Handler:
+    Exit Function
+
+Err_Handler:
+    MsgBox "Error " & Err.Number & ": " & Err.Description
+    Resume Exit_Handler
+End Function
+
+Private Function FillDir(colDirList As Collection, ByVal strFolder As String, strFileSpec As String, _
+    bIncludeSubfolders As Boolean)
+    'Build up a list of files, and then add add to this list, any additional folders
+    Dim strTemp As String
+    Dim colFolders As New Collection
+    Dim vFolderName As Variant
+
+    'Add the files to the folder.
+    strFolder = TrailingSlash(strFolder)
+    strTemp = Dir(strFolder & strFileSpec)
+    Do While strTemp <> vbNullString
+        colDirList.Add strFolder & strTemp
+        strTemp = Dir
+    Loop
+
+    If bIncludeSubfolders Then
+        'Build collection of additional subfolders.
+        strTemp = Dir(strFolder, vbDirectory)
+        Do While strTemp <> vbNullString
+            If (strTemp <> ".") And (strTemp <> "..") Then
+                If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0& Then
+                    colFolders.Add strTemp
+                End If
+            End If
+            strTemp = Dir
+        Loop
+        'Call function recursively for each subfolder.
+        For Each vFolderName In colFolders
+            Call FillDir(colDirList, strFolder & TrailingSlash(vFolderName), strFileSpec, True)
+        Next vFolderName
+    End If
+End Function
+
+Public Function TrailingSlash(varIn As Variant) As String
+    If Len(varIn) > 0& Then
+        If Right(varIn, 1&) = "\" Then
+            TrailingSlash = varIn
+        Else
+            TrailingSlash = varIn & "\"
+        End If
+    End If
+End Function
+'
+'
+''' END OF COPIED CODE '''''''''''''''''''''''''''''''''''''
+
+
+
+
+
+
diff --git a/mod_vsd_DocsShapesLinks.bas b/mod_vsd_DocsShapesLinks.bas
@@ -0,0 +1,86 @@
+Attribute VB_Name = "mod_vsd_DocsShapesLinks"
+' mod_vsd_DocsShapesLinks
+' 150313.AMG added Doc stuff renamed from mod_vsd_ShapesLinks
+' 150303.AMG created
+
+
+'
+' Visio Object Model Overview https://msdn.microsoft.com/en-us/library/cc160740.aspx
+' Visio Object Model Reference https://msdn.microsoft.com/en-us/library/office/ff765377(v=office.15).aspx
+'
+'
+' Visio Shapes ***********************
+'
+' Shapes collections are sub-objects of Page, Master or Shape
+' Shapes contained by other Shapes are caused by Grouping (a common occurance) and are known as sub-shapes
+'
+' Shapes Object https://msdn.microsoft.com/en-us/library/office/ff767583.aspx
+'
+'
+' Visio Hyperlinks ***********************
+'
+' Hyperlinks collections are sub-objects of Shape
+'
+' Hyperlinks object https://msdn.microsoft.com/en-us/library/office/ff766930.aspx
+' Hyperlink object https://msdn.microsoft.com/en-us/library/office/ff767835.aspx
+'
+
+
+Option Explicit
+
+
+Function EnumHyperlinks(shp As Shape)
+    Dim hlk As Hyperlink
+    If shp.Hyperlinks.Count > 0 Then
+        For Each hlk In shp.Hyperlinks
+            ' DoSomethingWith hlk
+            AddHyperlinkDetailToList hlk
+        Next
+    End If
+
+End Function
+
+' Docs
+
+
+
+' Docs and Shapes
+
+Function VisioOpenAndRecurseAllShapesInDoc(strFileName As String)
+    Dim doc As Document
+    Set doc = Application.Documents.Open(strFileName)
+    RecurseAllShapesInDoc doc
+    doc.Close
+    Set doc = Nothing
+End Function
+
+
+
+Function RecurseAllShapesInDoc(doc As Document)
+    Dim pg As Page
+    Dim shp As Shape
+
+    For Each pg In ActiveDocument.Pages
+        For Each shp In pg.Shapes
+            DoEachShapeAndSubShape shp
+        Next
+    Next
+
+End Function
+
+
+Function DoEachShapeAndSubShape(shp As Shape)
+    Dim subshp As Shape
+
+' do the main shape
+    EnumHyperlinks shp
+
+' if there are subshapes then recurse into them
+    If shp.Shapes.Count() <> 0 Then
+        For Each subshp In shp.Shapes
+            DoEachShapeAndSubShape subshp
+        Next
+    End If
+End Function
+
+
Original file line number	Diff line number	Diff line change
Expand Up		@@ -2,3 +2,9 @@ The following modules must remain closed source:

		mod_exc_FileLocations


		These have also been checked to extract any generic code of potential value:

		mod_acc_ImportBank