Hyperlink update trial run

artmg · Apr 17, 2015 · 1773b2a · 1773b2a
1 parent 190d855
commit 1773b2a
Show file tree

Hide file tree

Showing 2 changed files with 68 additions and 10 deletions.
diff --git a/mod_vsd_DocsShapesLinks.bas b/mod_vsd_DocsShapesLinks.bas
@@ -1,5 +1,7 @@
 Attribute VB_Name = "mod_vsd_DocsShapesLinks"
 ' mod_vsd_DocsShapesLinks
+
+' 150413.AMG begin doc and hyperlink update code
 ' 150313.AMG added Doc stuff renamed from mod_vsd_ShapesLinks
 ' 150303.AMG created
 
@@ -34,22 +36,56 @@ Function EnumHyperlinks(shp As Shape)
     If shp.Hyperlinks.Count > 0 Then
         For Each hlk In shp.Hyperlinks
             ' DoSomethingWith hlk
-            AddHyperlinkDetailToList hlk
+'            AddHyperlinkDetailToList hlk
+            UpdateHyperlinkDetail hlk
         Next
     End If
 
 End Function
 
+Function UpdateHyperlinkDetail(hlk As Hyperlink)
+    Dim strNewAddress As String
+    ' ignore empty hyperlinks
+    If hlk.Description & hlk.Address <> "" Then
+        strNewAddress = ""
+
+        AddHyperlinkDetailToList hlk, strNewAddress
+
+'        ExcelOutputWriteValue strCurrentFileFolder
+'        ExcelOutputWriteValue strCurrentFileNameOnly
+'        ExcelOutputWriteValue hlk.Shape.Name
+'        ExcelOutputWriteValue hlk.Shape.Text
+'        ExcelOutputWriteValue hlk.Description
+'        ExcelOutputWriteValue hlk.Address
+'        ExcelOutputWriteValue strNewAddress
+'        ExcelOutputNextRow
+
+        If Not bTrialRun Then
+            hlk.Address = strNewAddress
+        End If
+    End If
+End Function
+
+
+
+
+
 ' Docs
 
 
 
 ' Docs and Shapes
 
-Function VisioOpenAndRecurseAllShapesInDoc(strFileName As String)
+Function VisioOpenAndRecurseAllShapesInDoc( _
+  strFileName As String _
+, Optional bSave As Boolean = False _
+)
     Dim doc As Document
     Set doc = Application.Documents.Open(strFileName)
     RecurseAllShapesInDoc doc
+    If bSave Then
+        doc.Save
+    End If
     doc.Close
     Set doc = Nothing
 End Function

diff --git a/mod_vsd_ExportLinkInfoToExcel.bas b/mod_vsd_ExportLinkInfoToExcel.bas
@@ -1,5 +1,8 @@
 Attribute VB_Name = "mod_vsd_ExportLinkInfoToExcel"
 ' mod_vsd_ExportLinkInfoToExcel
+
+' 150414.AMG allow trial run for hyperlink update tests
+' 150413.AMG ignore empty hyperlinks (descr and url blank)
 ' 150316.AMG added headers and better descriptive columns
 ' 150303.AMG created
 
@@ -8,10 +11,12 @@ Attribute VB_Name = "mod_vsd_ExportLinkInfoToExcel"
 
 Option Explicit
 
-Dim strCurrentFileFolder As String
-Dim strCurrentFileNameOnly As String
+Public strCurrentFileFolder As String
+Public strCurrentFileNameOnly As String
+Public bTrialRun As Boolean
 
 Public Sub OutputLinkDetailsToWorksheet()
+    bTrialRun = True
     Dim strFileNames() As String
     strFileNames() = arrFilteredPathnamesInUserTree(strFilter:=".vsd", bRecurse:=True)
 ' func to return the number of elements without error (0 if none)
@@ -21,7 +26,8 @@ Public Sub OutputLinkDetailsToWorksheet()
         For ifile = 0 To UBound(strFileNames)
             strCurrentFileFolder = GetFolderFromFileName(strFileNames(ifile))
             strCurrentFileNameOnly = JustFileName(strFileNames(ifile))
-            VisioOpenAndRecurseAllShapesInDoc strFileNames(ifile)
+            AddDiagramToList
+            VisioOpenAndRecurseAllShapesInDoc strFileNames(ifile), Not (bTrialRun)
         Next
         ExcelOutputShow
     End If
@@ -35,16 +41,32 @@ Function PrepareListWithHeaders()
     ExcelOutputWriteValue "ShapeText"
     ExcelOutputWriteValue "HyperlinkText"
     ExcelOutputWriteValue "CurrentURL"
+    ExcelOutputWriteValue "NewURL"
     ExcelOutputNextRow
 End Function
 
-Function AddHyperlinkDetailToList(hlk As Hyperlink)
+Function AddDiagramToList()
     ExcelOutputWriteValue strCurrentFileFolder
     ExcelOutputWriteValue strCurrentFileNameOnly
-    ExcelOutputWriteValue hlk.Shape.Name
-    ExcelOutputWriteValue hlk.Shape.Text
-    ExcelOutputWriteValue hlk.Description
-    ExcelOutputWriteValue hlk.Address
+    ExcelOutputWriteValue ""
     ExcelOutputNextRow
 End Function
 
+Function AddHyperlinkDetailToList( _
+  hlk As Hyperlink _
+, Optional strNewAdress As String = "" _
+)
+    ' ignore empty hyperlinks
+    If hlk.Description & hlk.Address <> "" Then
+        ExcelOutputWriteValue strCurrentFileFolder
+        ExcelOutputWriteValue strCurrentFileNameOnly
+        ExcelOutputWriteValue hlk.Shape.Name
+        ExcelOutputWriteValue hlk.Shape.Text
+        ExcelOutputWriteValue hlk.Description
+        ExcelOutputWriteValue hlk.Address
+        ExcelOutputWriteValue strNewAdress
+        ExcelOutputNextRow
+    End If
+End Function
+
+