From d244a16475a1991d5d4b64c2d610864d1c45a62d Mon Sep 17 00:00:00 2001 From: artmg Date: Mon, 16 Mar 2015 13:13:51 +0000 Subject: [PATCH] Visio URLs --- Closed.txt.txt | 6 + mod_off_ExportListToExcel.bas | 9 +- mod_off_FilesFoldersSitesLinks.bas | 174 ++++++++++++++++++++++---- mod_vsd_DocsShapesLinks.bas | 86 +++++++++++++ mod_vsd_ExportLinkInfoToExcel.bas | 37 +++++- mod_vsd_ExportLinkInfoToExcel.bas.bak | 23 ++++ 6 files changed, 307 insertions(+), 28 deletions(-) create mode 100644 mod_vsd_DocsShapesLinks.bas create mode 100644 mod_vsd_ExportLinkInfoToExcel.bas.bak diff --git a/Closed.txt.txt b/Closed.txt.txt index f44e034..7e78081 100644 --- 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 index 18d7c61..39ccfee 100644 --- 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 index 00f62d1..86025bb 100644 --- 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 new file mode 100644 index 0000000..abf8b64 --- /dev/null +++ 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 + + diff --git a/mod_vsd_ExportLinkInfoToExcel.bas b/mod_vsd_ExportLinkInfoToExcel.bas index eda196f..c077ef1 100644 --- a/mod_vsd_ExportLinkInfoToExcel.bas +++ b/mod_vsd_ExportLinkInfoToExcel.bas @@ -1,23 +1,50 @@ Attribute VB_Name = "mod_vsd_ExportLinkInfoToExcel" ' mod_vsd_ExportLinkInfoToExcel -' 150303.AMG +' 150316.AMG added headers and better descriptive columns +' 150303.AMG created ' depends on: ' mod_vsd_ShapesLinks Option Explicit +Dim strCurrentFileFolder As String +Dim strCurrentFileNameOnly As String + Public Sub OutputLinkDetailsToWorksheet() - - ExcelOutputCreateWorksheet - RecurseAllShapesInDoc ActiveDocument + Dim strFileNames() As String + strFileNames() = arrFilteredPathnamesInUserTree(strFilter:=".vsd", bRecurse:=True) +' func to return the number of elements without error (0 if none) + If strFileNames(0) <> "" Then + PrepareListWithHeaders + Dim ifile As Integer + For ifile = 0 To UBound(strFileNames) + strCurrentFileFolder = GetFolderFromFileName(strFileNames(ifile)) + strCurrentFileNameOnly = JustFileName(strFileNames(ifile)) + VisioOpenAndRecurseAllShapesInDoc strFileNames(ifile) + Next + ExcelOutputShow + End If End Sub +Function PrepareListWithHeaders() + ExcelOutputCreateWorksheet + ExcelOutputWriteValue "DiagramFolder" + ExcelOutputWriteValue "DiagramFilename" + ExcelOutputWriteValue "ShapeName" + ExcelOutputWriteValue "ShapeText" + ExcelOutputWriteValue "HyperlinkText" + ExcelOutputWriteValue "CurrentURL" + ExcelOutputNextRow +End Function Function AddHyperlinkDetailToList(hlk As Hyperlink) + ExcelOutputWriteValue strCurrentFileFolder + ExcelOutputWriteValue strCurrentFileNameOnly ExcelOutputWriteValue hlk.Shape.Name + ExcelOutputWriteValue hlk.Shape.Text + ExcelOutputWriteValue hlk.Description ExcelOutputWriteValue hlk.Address ExcelOutputNextRow - End Function diff --git a/mod_vsd_ExportLinkInfoToExcel.bas.bak b/mod_vsd_ExportLinkInfoToExcel.bas.bak new file mode 100644 index 0000000..eda196f --- /dev/null +++ b/mod_vsd_ExportLinkInfoToExcel.bas.bak @@ -0,0 +1,23 @@ +Attribute VB_Name = "mod_vsd_ExportLinkInfoToExcel" +' mod_vsd_ExportLinkInfoToExcel +' 150303.AMG + +' depends on: +' mod_vsd_ShapesLinks + +Option Explicit + +Public Sub OutputLinkDetailsToWorksheet() + + ExcelOutputCreateWorksheet + RecurseAllShapesInDoc ActiveDocument +End Sub + + +Function AddHyperlinkDetailToList(hlk As Hyperlink) + ExcelOutputWriteValue hlk.Shape.Name + ExcelOutputWriteValue hlk.Address + ExcelOutputNextRow + +End Function +