├── README.md ├── Template_Word_2010_2013 ├── PlantUML_Template_v32.dotm └── module │ ├── GDIHandling │ ├── PlantUML │ ├── PlantumlFTP │ ├── Registry │ └── ShellUtil ├── Template_Word_2016 ├── PlantUML_Template_v35.dotm └── module │ ├── GDIHandling │ ├── GetLocalOneDrivePath │ ├── LibFileTools │ ├── PlantUML │ ├── PlantumlFTP │ ├── Registry │ └── ShellUtil └── images └── menu.png /README.md: -------------------------------------------------------------------------------- 1 | 2 | # INTRODUCTION 3 | This repository contains the Word Template Add-in for PlantUML. 4 | 5 | The PlantUML Word template allows using PlantUML directly from MS Word 2010/2013 on Windows (32/64 bit) without need to alter document templates or edit VBA macro's. MS Word Version 2007 may work, but is not tested. 6 | 7 | Also tested in MS Word 2016, need to copy contents of "Template_Word_2016" folder. 8 | *Updated 20190502: Now MS Word 2016 accepts SVG images, you can try generating them by selecting "Vector Graphics ON" on PlantUML tab's Preferences. 9 | 10 | # INSTALLATION 11 | First time: 12 | * install the JDK: https://www.oracle.com/il-en/java/technologies/downloads/#jdk21-windows 13 | * install the right template version in Word 14 | * copy the (.dotm) file in to `%appdata%\Microsoft\Word\STARTUP` 15 | * note: .dotm = Word Doc Template (office 2007 and newer) with Macro's enabled 16 | * copy Plantuml.jar to `%appdata%\Microsoft\Word\STARTUP` folder 17 | * install GraphViz 18 | * https://graphviz.gitlab.io/_pages/Download/Download_windows.html 19 | * use installer if you have rights to install applications; this will install graphviz in your program files (x86) 20 | * use zip for portable installation 21 | * extract in `%appdata%\GraphViz` 22 | * (executable is then in `%appdata%\GraphViz\release\bin\dot.exe`) 23 | * if alternative portable installation, please set environment variable `GRAPHVIZ_DOT` to location of DOT.EXE 24 | * restart Word. You now should have a PlantUML menu! 25 | 26 | 27 | # USING 28 | Once installed, a special menu (PlantUML) should be available in Word as tab "PlantUML" 29 | 30 | ![](https://raw.githubusercontent.com/plantuml/word-template/master/images/menu.png) 31 | 32 | Icon | Description 33 | -- | -- 34 | P | show paragraph marks 35 | Show PlantUML | reveal (green text) of PlantUML image sources (for editing) 36 | Hide PlantUML | hide source, just show generated pictures (before releasing a document for review/UCC) 37 | UML.1 | Generate current diagram (cursor in green PlantUML definition) 38 | UML.* | Generate all (note: this may take seconds up to a minute for 100+ pictures). Press Ctrl-Break to abort. 39 | 40 | Note: If you share a Word Document with someone that does not have this Add-in installed, they will see the PlantUML source as well as the diagram. 41 | 42 | # VBA CODE 43 | For convenience, the current [VBA module](https://github.com/plantuml/word-template/tree/master/module) are listed in the current repository: 44 | * GDIHanling 45 | * PlantUML 46 | * PlantumlFTP 47 | * Registry 48 | * ShellUtil 49 | 50 | This allows to clearly follow VBA code changes over versions. 51 | 52 | -------------------------------------------------------------------------------- /Template_Word_2010_2013/PlantUML_Template_v32.dotm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/plantuml/word-template/ae00c5684e9cb2e66386cdfc08cda318385d454b/Template_Word_2010_2013/PlantUML_Template_v32.dotm -------------------------------------------------------------------------------- /Template_Word_2010_2013/module/GDIHandling: -------------------------------------------------------------------------------- 1 | 2 | 'This module provides a LoadPictureGDI function, which can 3 | 'be used instead of VBA's LoadPicture, to load a wide variety 4 | 'of image types from disk - including png. 5 | ' 6 | 'The png format is used in Office 2007 to provide images that 7 | 'include an alpha channel for each pixel's transparency 8 | ' 9 | 'Author: Stephen Bullen 10 | 'Date: 31 October, 2006 11 | 'Email: stephen@oaltd.co.uk 12 | 13 | Option Explicit 14 | 15 | 'Declare a UDT to store a GUID for the IPicture OLE Interface 16 | Private Type GUID 17 | Data1 As Long 18 | Data2 As Integer 19 | Data3 As Integer 20 | Data4(0 To 7) As Byte 21 | End Type 22 | 23 | 'Declare a UDT to store the bitmap information 24 | Private Type PICTDESC 25 | Size As Long 26 | Type As Long 27 | hPic As Long 28 | hPal As Long 29 | End Type 30 | 31 | 'Declare a UDT to store the GDI+ Startup information 32 | Private Type GdiplusStartupInput 33 | GdiplusVersion As Long 34 | DebugEventCallback As Long 35 | SuppressBackgroundThread As Long 36 | SuppressExternalCodecs As Long 37 | End Type 38 | 39 | 'Windows API calls into the GDI+ library 40 | Private Declare Function GdiplusStartup Lib "GDIPlus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long 41 | Private Declare Function GdipCreateBitmapFromFile Lib "GDIPlus" (ByVal filename As Long, bitmap As Long) As Long 42 | Private Declare Function GdipCreateHBITMAPFromBitmap Lib "GDIPlus" (ByVal bitmap As Long, hbmReturn As Long, ByVal background As Long) As Long 43 | Private Declare Function GdipDisposeImage Lib "GDIPlus" (ByVal image As Long) As Long 44 | Private Declare Function GdiplusShutdown Lib "GDIPlus" (ByVal token As Long) As Long 45 | Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PICTDESC, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long 46 | 47 | 48 | ' Procedure: LoadPictureGDI 49 | ' Purpose: Loads an image using GDI+ 50 | ' Returns: The image as an IPicture Object 51 | Public Function LoadPictureGDI(ByVal sFilename As String) As IPicture 52 | 53 | Dim uGdiInput As GdiplusStartupInput 54 | Dim hGdiPlus As Long 55 | Dim lResult As Long 56 | Dim hGdiImage As Long 57 | Dim hBitmap As Long 58 | 59 | 'Initialize GDI+ 60 | uGdiInput.GdiplusVersion = 1 61 | lResult = GdiplusStartup(hGdiPlus, uGdiInput) 62 | 63 | If lResult = 0 Then 64 | 65 | 'Load the image 66 | lResult = GdipCreateBitmapFromFile(StrPtr(sFilename), hGdiImage) 67 | 68 | If lResult = 0 Then 69 | 70 | 'Create a bitmap handle from the GDI image 71 | lResult = GdipCreateHBITMAPFromBitmap(hGdiImage, hBitmap, 0) 72 | 73 | 'Create the IPicture object from the bitmap handle 74 | Set LoadPictureGDI = CreateIPicture(hBitmap) 75 | 76 | 'Tidy up 77 | GdipDisposeImage hGdiImage 78 | End If 79 | 80 | 'Shutdown GDI+ 81 | GdiplusShutdown hGdiPlus 82 | End If 83 | 84 | End Function 85 | 86 | 87 | ' Procedure: CreateIPicture 88 | ' Purpose: Converts a image handle into an IPicture object. 89 | ' Returns: The IPicture object 90 | Private Function CreateIPicture(ByVal hPic As Long) As IPicture 91 | 92 | Dim lResult As Long, uPicInfo As PICTDESC, IID_IDispatch As GUID, IPic As IPicture 93 | 94 | 'OLE Picture types 95 | Const PICTYPE_BITMAP = 1 96 | 97 | ' Create the Interface GUID (for the IPicture interface) 98 | With IID_IDispatch 99 | .Data1 = &H7BF80980 100 | .Data2 = &HBF32 101 | .Data3 = &H101A 102 | .Data4(0) = &H8B 103 | .Data4(1) = &HBB 104 | .Data4(2) = &H0 105 | .Data4(3) = &HAA 106 | .Data4(4) = &H0 107 | .Data4(5) = &H30 108 | .Data4(6) = &HC 109 | .Data4(7) = &HAB 110 | End With 111 | 112 | ' Fill uPicInfo with necessary parts. 113 | With uPicInfo 114 | .Size = Len(uPicInfo) 115 | .Type = PICTYPE_BITMAP 116 | .hPic = hPic 117 | .hPal = 0 118 | End With 119 | 120 | ' Create the Picture object. 121 | lResult = OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, IPic) 122 | 123 | ' Return the new Picture object. 124 | Set CreateIPicture = IPic 125 | 126 | End Function 127 | 128 | 129 | -------------------------------------------------------------------------------- /Template_Word_2010_2013/module/PlantUML: -------------------------------------------------------------------------------- 1 | ' ======================================================================== 2 | ' Plantuml : a free UML diagram generator 3 | ' ======================================================================== 4 | ' 5 | ' (C) Copyright 2009-2017, Arnaud Roques 6 | ' 7 | ' Project Info: http://plantuml.com 8 | ' 9 | ' If you like this project or if you find it useful, you can support us at: 10 | ' 11 | ' http://plantuml.com/patreon (only 1$ per month!) 12 | ' http://plantuml.com/paypal 13 | ' 14 | ' This file is part of PlantUML. 15 | ' 16 | ' Plantuml is free software; you can redistribute it and/or modify it 17 | ' under the terms of the GNU General Public License as published by 18 | ' the Free Software Foundation, either version 3 of the License, or 19 | ' (at your option) any later version. 20 | ' 21 | ' Plantuml distributed in the hope that it will be useful, but 22 | ' WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY 23 | ' or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public 24 | ' License for more details. 25 | ' 26 | ' You should have received a copy of the GNU General Public 27 | ' License along with this library; if not, write to the Free Software 28 | ' Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, 29 | ' USA. 30 | ' 31 | ' [Java is a trademark or registered trademark of Sun Microsystems, Inc. 32 | ' in the United States and other countries.] 33 | ' 34 | ' Original Author: Arnaud Roques 35 | ' Word Macro: Alain Bertucat / Matthieu Sabatier 36 | ' Improved error management : Christopher Fuhrman 37 | ' http://vbadud.blogspot.fr/2008/12/how-to-set-and-reset-track-changes.html 38 | ' Version 008 39 | ' changes by Adriaan van den Brand & Pieter Smith 40 | ' - direct writing of files (instead of creating documents and using paste & save) 41 | ' - fixed bug in 006/007 version which inserted wrong images (because the javalock didn't work 42 | ' use ShellUtil which waits until completion of java 43 | ' - integrated in word template for easy integration in word environment 44 | ' version 010 (template 2.6) 45 | ' changes by Adriaan van den Brand 46 | ' - use of utf-8 for plantuml files 47 | ' - add @rescale for post processing scale 48 | ' - fix language dependency in styles 49 | ' - add autoformat on/off functions' 50 | ' - remove add-in toolbar (obsolete by plantuml toolbar) (toolbar and statusbutton code commented out) 51 | ' Open issue: onload doesn't work yet (intended for feedback via ribbon) 52 | ' Version 011 53 | ' changes by Adriaan van den Brand 54 | ' add preferences 55 | ' add png/eps selector (default remains eps) 56 | ' Version 012 57 | ' Add include path: document path (thanks Matt) 58 | ' Version 013 59 | ' copy/paste compatibility (now style is toggled from hidden/visible instead of display hidden text 60 | ' auto scale (reduce) to fit page 61 | ' 62 | ' version 014 63 | ' 64 bit compatibility added (provided by Andreas Brusinsky, Gil Fuchs, Ren Vleer) 64 | ' version 015 65 | ' added ftp 66 | ' version 032 67 | ' see http://plantuml.sourceforge.net/qa/?qa=4083/plantuml_template_v30-does-not-work 68 | ' see http://plantuml.sourceforge.net/qa/?qa=3329/word-2010-runtime-error-when-generating-new-plantuml-image 69 | ' replace ActiveDocument.PageSetup with currentparagraph.PageSetup to solve sections issues 70 | 71 | 72 | #If Win64 Or VBA7 Then 73 | Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 74 | #Else 75 | Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 76 | #End If 77 | 78 | 79 | Const startuml = "@start" 80 | Const enduml = "@end" 81 | 82 | Dim vectorgraphics As Boolean 83 | Dim useFTP As Boolean 84 | Dim FTPURL As String 85 | 86 | 87 | 88 | 89 | Function get_gfx_extension() As String 90 | If vectorgraphics Then 91 | get_gfx_extension = "*.eps" 92 | Else 93 | get_gfx_extension = "*.png" 94 | End If 95 | End Function 96 | 97 | 98 | Function get_plantuml_options() As String 99 | Dim options As String 100 | options = "" 101 | If vectorgraphics Then 102 | options = options + " -teps" 103 | End If 104 | 105 | get_plantuml_options = options 106 | End Function 107 | 108 | Function getExePath(searchfor As String, ByRef try As String) As String 109 | Set fs = CreateObject("Scripting.FileSystemObject") 110 | 111 | nbTemplates = ActiveDocument.Parent.Templates.Count 112 | mainPath = ActiveDocument.Path 113 | try = ActiveDocument.Path & "\" 114 | 115 | nb = InStrRev(mainPath, "\") 116 | Do While nb > 1 And fs.FileExists(mainPath + searchfor) = False 117 | mainPath = Left(mainPath, nb - 1) 118 | try = try & vbCrLf & mainPath & "\" 119 | nb = InStrRev(mainPath, "\") 120 | Loop 121 | 122 | ' see http://plantuml.sourceforge.net/qa/?qa=4083/plantuml_template_v30-does-not-work 123 | ' In case mainPath is the empty string as the active document is the empty string, 124 | ' and in case the plantuml.jar can be found in the current directory, the below 125 | ' code results in mainPath being the empty string which would work properly if 126 | ' the calling method would not check for an empty string as execution path 127 | ' and state this is wrong and has to fail. Therefore, change main path in case 128 | ' it is an empty string at this point with an explicit, not empty string stating to 129 | ' use the current folder as relative path. 130 | If mainPath = "" Then 131 | mainPath = ".\" 132 | End If 133 | 134 | For I = 1 To nbTemplates 135 | If fs.FileExists(mainPath + searchfor) = False Then 136 | mainPath = ActiveDocument.Parent.Templates.Item(I).Path 137 | try = try & vbCrLf & ActiveDocument.Parent.Templates.Item(I).Path & "\" 138 | nb = InStrRev(mainPath, "\") 139 | Do While nb > 1 And fs.FileExists(mainPath + searchfor) = False 140 | mainPath = Left(mainPath, nb - 1) 141 | try = try & vbCrLf & mainPath & "\" 142 | nb = InStrRev(mainPath, "\") 143 | Loop 144 | End If 145 | Next I 146 | 147 | If fs.FileExists(mainPath + searchfor) Then 148 | getExePath = mainPath 149 | Else 150 | getExePath = "Error : Cannot find plantuml.jar in :" & vbCrLf & try 151 | End If 152 | 153 | 154 | End Function 155 | 156 | ' ========================================================= 157 | ' This function returns the path for plantuml.jar 158 | Function getJarPath() As String 159 | Set fs = CreateObject("Scripting.FileSystemObject") 160 | Dim trypath As String 161 | trypath = "" 162 | jarPath = getExePath("\plantuml.jar", trypath) 163 | If (jarPath <> "") And fs.FileExists(jarPath + "\plantuml.jar") Then 164 | getJarPath = jarPath 165 | Else 166 | getJarPath = "Error : Cannot find plantuml.jar in :" & vbCrLf & trypath 167 | End If 168 | 169 | End Function 170 | 171 | 172 | 173 | ' ========================================================= 174 | ' This function returns the path for plantuml.jar 175 | Function getDotPath() As String 176 | Set fs = CreateObject("Scripting.FileSystemObject") 177 | Dim trypath As String 178 | Dim searchfor As String 179 | trypath = Environ("%APPDATA%") 180 | If Environ("GRAPHVIZ_DOT") <> "" Then Exit Function 181 | searchfor = "\release\bin\dot.exe" 182 | dotPath = getExePath(searchfor, trypath) 183 | If (dotPath <> "") And fs.FileExists(dotPath + searchfor) Then 184 | getDotPath = dotPath + searchfor 185 | Else 186 | getDotPath = "" '"Error : Cannot find graphviz in :" & vbCrLf & trypath 187 | End If 188 | End Function 189 | 190 | 191 | ' ========================================================= 192 | ' Print out the used plantuml.jar 193 | Sub ShowPlantumlJarPath() 194 | Set fs = CreateObject("Scripting.FileSystemObject") 195 | jarPath = getJarPath() 196 | If jarPath <> "" And fs.FileExists(jarPath) Then 197 | MsgBox "OK : " & jarPath 198 | Else 199 | MsgBox jarPath 200 | End If 201 | End Sub 202 | ' ========================================================= 203 | ' Used to migrate from previous PlantUML macro version 204 | Sub RemoveOldVersionPlantUMLSyles() 205 | On Error GoTo DeleteEnd 206 | ActiveDocument.Styles("PlantUML").Delete 207 | On Error GoTo 0 208 | DeleteEnd: 209 | On Error GoTo 0 210 | Call Macro_UML_all 211 | 212 | End Sub 213 | ' ========================================================= 214 | ' Called when the user click on "UML.*" 215 | Sub Macro_UML_all() 216 | Macro_UML ("all") 217 | End Sub 218 | 219 | ' ========================================================= 220 | Sub Macro_UML_styles() 221 | CreateStyle (True) 222 | End Sub 223 | 224 | ' ========================================================= 225 | ' Called when the user click on "UML.1" 226 | Function Macro_UML_parg() 227 | Macro_UML ("parg") 228 | End Function 229 | 230 | ' ========================================================= 231 | Function WriteToFile(sFile, sText As String) 232 | Dim objStream As Object 233 | Set objStream = CreateObject("ADODB.Stream") 234 | With objStream 235 | .Type = 2 ' Stream type = text / string data 236 | .Mode = 3 237 | '.Charset = "ascii" ' plantUML can only deal with ASCII: Setting to ASCII kills Word's autoformatting 238 | .Charset = "utf-8" ' plantUML can only deal with ASCII: Setting to ASCII kills Word's autoformatting 239 | .Open 240 | .WriteText sText 241 | .SaveToFile sFile, 2 242 | End With 243 | End Function 244 | 245 | Function Macro_UML(scope) As String 246 | ' Generate diagrams image from a PlantUML source textual description in the Word Document 247 | ' Scope can be "parg" or "all" 248 | ' 249 | ' - Initialisations 250 | Dim currentIndex As Long 251 | Dim ftphandle As Long 252 | Dim JavaCommand As String 253 | Dim GraphVizOption As String 254 | GraphVizOption = "" 255 | Dim scalefiles As Scripting.Dictionary 256 | Set scalefiles = New Scripting.Dictionary 257 | ToolbarInit 258 | ' Set statusButton = CommandBars("UML").Controls(6) 259 | If RegKeyRead("VectorGraphics") = "ON" Then 260 | vectorgraphics = True 261 | End If 262 | If RegKeyRead("FTPMode") = "ON" Then 263 | useFTP = True 264 | End If 265 | 266 | FTPURL = RegKeyRead("FTPURL", "127.0.0.1:4242") 267 | 268 | 269 | Call CreateStyle(True) 270 | Call CreateStyleImg 271 | Call ShowPlantuml 272 | 273 | Call ShowHiddenText 274 | Selection.Range.Select 275 | ' 276 | ' documentId is the filename with its path, without extension 277 | ' 278 | documentId = ActiveDocument.Name 279 | documentId = Left(documentId, Len(documentId) - 4) 280 | 281 | ' Check for the presente of plantuml.jar 282 | 283 | Set fs = CreateObject("Scripting.FileSystemObject") 284 | jarPath = getJarPath() 285 | If (jarPath = "") Or fs.FileExists(jarPath + "\plantuml.jar") = False Then 286 | MsgBox jarPath 287 | GoTo Macro_UML_exit 288 | End If 289 | dotPath = getDotPath() 290 | If dotPath <> "" Then 291 | GraphVizOption = " -graphvizdot """ & dotPath & """" 292 | End If 293 | 294 | ' - Phase 1 295 | ' We create a file text per bloc of diagrams 296 | ' We look for @startuml 297 | ' We open the textfile in background (visible:=false) 298 | ' We add to the name a number on 4 digit 299 | ' The text bloc is put on "PlantUML" style 300 | ' Then the bloc is copied into the text file 301 | 302 | ' statusButton.Caption = "Extract" 303 | ' statusButton.Visible = False 304 | ' statusButton.Visible = True 305 | If scope = "all" Then 306 | Set parsedtext = ActiveDocument.Content 307 | isForward = True 308 | Else 309 | Set parsedtext = Selection.Range 310 | ' parsedtext.Collapse 311 | isForward = False 312 | End If 313 | 314 | parsedtext.Find.Execute FindText:=startuml, Forward:=isForward 315 | If parsedtext.Find.Found = True Then 316 | 'We keep the the first line only "@startuml" with the carriage return 317 | Set singleparagraph = parsedtext.Paragraphs(1).Range 318 | singleparagraph.Collapse 319 | Else 320 | GoTo Macro_UML_exit 321 | End If 322 | Application.ScreenUpdating = False 323 | jobDone = False 324 | If useFTP Then 325 | ftphandle = ftpOpen(FTPURL) 326 | If ftphandle <= 0 Then 327 | MsgBox "Cannot create ftp connection, aborting" 328 | Exit Function 329 | End If 330 | End If 331 | 332 | Do While parsedtext.Find.Found = True And _ 333 | (scope = "all" Or currentIndex < 1) And Not jobDone 334 | ' statusButton.Caption = "Extract." & currentIndex + 1 335 | ' statusButton.Visible = False 336 | ' statusButton.Visible = True 337 | Set currentparagraph = parsedtext.Paragraphs(1) 338 | Set paragraphRange = currentparagraph.Range 339 | paragraphRange.Collapse 340 | jobDone = False 341 | Do Until jobDone 342 | If Left(currentparagraph.Range.Text, Len(startuml)) = startuml Then 343 | Set paragraphRange = currentparagraph.Range 344 | paragraphRange.Collapse 345 | 346 | End If 347 | paragraphRange.MoveEnd Unit:=wdParagraph 348 | If Left(currentparagraph.Range.Text, Len(enduml)) = enduml Then 349 | Dim s As String 350 | paragraphRange.Style = "PlantUML" 351 | s = paragraphRange.Text 352 | currentIndex = currentIndex + 1 353 | 354 | factor = 0# 355 | On Error Resume Next 356 | p = InStr(LCase(s), "@rescale ") 357 | If p > 0 Then 358 | 359 | endscale = InStr(p + 9, s, Chr(13)) - p - 9 360 | factorstr = Mid(s, p + 9, endscale) 361 | factor = Val(factorstr) 362 | End If 363 | On Error GoTo 0 364 | 365 | textFileId = documentId & "_extr" & Right("000" & currentIndex, 4) & ".txt" 366 | If factor > 0 Then 367 | scalefiles(Replace(textFileId, ".txt", "")) = factor 368 | End If 369 | If scope = "fetch" Then 370 | Macro_UML = Mid(s, 1, Len(s) - 1) 371 | Application.ScreenUpdating = True 372 | Exit Function 373 | End If 374 | filename = jarPath & "\" & textFileId 375 | 376 | WriteToFile filename, Mid(s, 1, Len(s) - 1) 377 | If useFTP Then 378 | retValue = FtpStor(ftphandle, jarPath & "\" & textFileId, textFileId) 379 | End If 380 | 381 | If scope <> "all" Then 382 | jobDone = True 383 | End If 384 | 385 | End If 386 | Set currentparagraph = currentparagraph.Next 387 | If currentparagraph Is Nothing Then 388 | jobDone = True 389 | End If 390 | Loop 391 | parsedtext.Collapse Direction:=wdCollapseEnd 392 | If scope = "all" Then 393 | parsedtext.Find.Execute FindText:=startuml, Forward:=True 394 | End If 395 | Loop 396 | Application.ScreenUpdating = True 397 | ' 398 | ' We create a lock file that will be deleted by the Java program to indicate the end of Java process 399 | ' 400 | ' statusButton.Caption = "Gener" 401 | ' statusButton.Visible = False 402 | ' statusButton.Visible = True 403 | 404 | ' 405 | ' Call to PlantUML to generate images from text descriptions 406 | ' 407 | ' version 012 : add include path to document path 408 | ' if document is loaded from disk (by drive letter) 409 | If useFTP Then 410 | For I = 1 To currentIndex 411 | imageId = documentId & "_extr" & Right("000" & I, 4) & ".png" 412 | imageName = jarPath & "\" & imageId 413 | retValue = FtpRetr(ftphandle, imageName, imageId) 414 | Next I 415 | 'Sleep 200 416 | Else 417 | Set lockFile = Documents.Add(Visible:=False) 418 | lockFile.SaveAs filename:=jarPath & "\javaumllock.tmp", FileFormat:=wdFormatText 419 | lockFile.Close 420 | 421 | Dim javaoptions 422 | javaoptions = " -Dplantuml.include.path=" & Chr(34) & ActiveDocument.Path & Chr(34) & " " 423 | 424 | JavaCommand = "java " & javaoptions _ 425 | & "-classpath """ & jarPath & "\plantuml.jar;" & _ 426 | jarPath & "\plantumlskins.jar"" net.sourceforge.plantuml.Run -word """ & jarPath & "/""" & GraphVizOption & get_plantuml_options() 427 | 428 | 429 | 430 | 431 | Result = ShellAndWait(JavaCommand, 0, vbMinimizedFocus, AbandonWait) 432 | If Result <> Success Then 433 | MsgBox "Java command execution failed (break key?)" 434 | Return 435 | End If 436 | 437 | 438 | ' This sleep is needed, but we don't know why... 439 | Sleep 1000 440 | End If 441 | ' 442 | ' Phase 2 : 443 | ' Insertion of images into the word document 444 | ' We insert the image after the textual block that describe the diagram 445 | ' 446 | jobDone = False 447 | nrOfImages = currentIndex 448 | currentIndex = 0 449 | 'Sleep 50 * nrOfImages 450 | 451 | ' We wait for the file javaumllock.tmp to be deleted by Java 452 | ' which means that the process is ended 453 | ' 454 | ' get images via ftp or wait for java to end 455 | If useFTP Then 456 | 457 | Else 458 | Do 459 | currentIndex = currentIndex + 1 460 | ' statusButton.Caption = "Gener." & currentIndex 461 | ' statusButton.Visible = False 462 | ' statusButton.Visible = True 463 | 464 | DoEvents 465 | 466 | Sleep 100 ' Sleep 500 467 | If fs.FileExists(jarPath & "\javaumllock.tmp") = False Then 468 | jobDone = True 469 | Exit Do 470 | End If 471 | If currentIndex > 30 Then 472 | ' statusButton.Visible = False 473 | MsgBox ("Java Timeout. Aborted.") 474 | Exit Do 475 | End If 476 | Loop 477 | 478 | If jobDone = False Then 479 | End 480 | End If 481 | End If 482 | 483 | ' statusButton.Caption = "Inser." 484 | ' statusButton.Visible = False 485 | ' statusButton.Visible = True 486 | 487 | If scope = "all" Then 488 | Set parsedtext = ActiveDocument.Content 489 | isForward = True 490 | Else 491 | Set parsedtext = singleparagraph 492 | isForward = True 493 | End If 494 | parsedtext.Find.Execute FindText:=enduml, Forward:=isForward 495 | currentIndex = 0 496 | bTrackRevFlag = ActiveDocument.TrackRevisions 497 | ActiveDocument.TrackRevisions = False 498 | Do While parsedtext.Find.Found = True And (scope = "all" Or currentIndex < 1) 499 | currentIndex = currentIndex + 1 500 | ' statusButton.Caption = "Inser." & currentIndex 501 | ' statusButton.Visible = False 502 | ' statusButton.Visible = True 503 | On Error GoTo LastParagraph 504 | 505 | 'error handler will assume that the @enduml is at the last paragraph of the document. Not always true 506 | 507 | Set currentparagraph = parsedtext.Paragraphs(1).Next.Range 508 | Do While currentparagraph.InlineShapes.Count > 0 And currentparagraph.Style = "PlantUMLImg" 509 | currentparagraph.Delete 510 | Set currentparagraph = parsedtext.Paragraphs(1).Next.Range 511 | Loop 512 | On Error GoTo 0 513 | Set currentRange = currentparagraph 514 | imagesDirectory = jarPath & "\" & documentId & "_extr" & Right("000" & currentIndex, 4) & get_gfx_extension() 515 | image = Dir(imagesDirectory) 516 | While image <> "" 517 | ' Contain the text of the error 518 | errorTextFile = jarPath & "\" & Left(image, Len(image) - 4) & ".err" 519 | BaseName = Left(image, Len(image) - 4) 520 | Set currentparagraph = ActiveDocument.Paragraphs.Add(Range:=currentRange).Range 521 | Set currentRange = currentparagraph.Paragraphs(1).Next.Range 522 | currentparagraph.Style = "PlantUMLImg" 523 | currentparagraph.Collapse 524 | 525 | Set image = currentparagraph.InlineShapes.AddPicture _ 526 | (filename:=jarPath & "\" & image _ 527 | , LinkToFile:=False, SaveWithDocument:=True) 528 | 529 | ' check if scale was forced in plantuml code 530 | If scalefiles(CStr(BaseName)) > 0.1 And scalefiles(CStr(BaseName)) < 5 Then 531 | image.ScaleWidth = scalefiles(CStr(BaseName)) * 100 532 | image.ScaleHeight = scalefiles(CStr(BaseName)) * 100 533 | Else 534 | ' new 2.9 535 | ' default: autoscale; reduce to fit if > margin. 100% if picture fits 536 | With image 537 | .LockAspectRatio = msoFalse 538 | .ScaleWidth = 100 539 | .ScaleHeight = 100 540 | percentW = currentparagraph.PageSetup.TextColumns.Width / image.Width 541 | percentH = (currentparagraph.PageSetup.PageHeight - currentparagraph.PageSetup.TopMargin - currentparagraph.PageSetup.BottomMargin) / image.Height 542 | If percentH < percentW Then percentW = percentH 543 | If percentW < 1 Then 544 | .ScaleWidth = percentW * 100 545 | .ScaleHeight = percentW * 100 546 | End If 547 | End With 548 | End If 549 | 550 | If fs.FileExists(errorTextFile) Then 551 | image.AlternativeText = LoadTextFile(errorTextFile) 552 | Beep 553 | Else 554 | image.AlternativeText = "Generated by PlantUML" 555 | End If 556 | 557 | If image.ScaleHeight > 100 Or image.ScaleWidth > 100 Then 558 | image.Reset 559 | End If 560 | image = Dir() 561 | Wend 562 | parsedtext.Collapse Direction:=wdCollapseEnd 563 | parsedtext.Find.Execute FindText:=enduml, Forward:=True 564 | Loop 565 | ActiveDocument.TrackRevisions = bTrackRevFlag 566 | 567 | ' 568 | ' Phase 3 : suppression of temporary files (text and PNG) 569 | ' 570 | Phase3: 571 | ' statusButton.Caption = "Delete" 572 | ' statusButton.Visible = False 573 | ' statusButton.Visible = True 574 | If Not useFTP Then 575 | On Error Resume Next 576 | 577 | Kill (jarPath & "\" & documentId & "_extr*.*") 578 | On Error GoTo 0 579 | Else 580 | ftpClose ftphandle 581 | End If 582 | Macro_UML_exit: 583 | 584 | ' statusButton.Visible = False 585 | 586 | 'We show the hidden description text 587 | Call ShowHiddenText 588 | DoubleCheckStyle 589 | Exit Function 590 | 591 | 592 | ' This is need when the very last line of the Word document (or table cell) is @enduml 593 | LastParagraph: 594 | Selection.EndKey Unit:=wdStory 595 | Selection.TypeParagraph 596 | Selection.ClearFormatting 597 | 598 | imagesDirectory = jarPath & "\" & documentId & "_extr" & Right("000" & currentIndex, 4) & get_gfx_extension 599 | image = Dir(imagesDirectory) 600 | While image <> "" 601 | ' Contain the text of the error 602 | errorTextFile = jarPath & "\" & Left(image, Len(image) - 4) & ".err" 603 | 604 | Set currentparagraph = ActiveDocument.Paragraphs.Add.Range 605 | Set currentRange = currentparagraph.Paragraphs(1).Next.Range 606 | currentparagraph.Style = "PlantUMLImg" 607 | currentparagraph.Collapse 608 | 609 | Set image = currentparagraph.InlineShapes.AddPicture _ 610 | (filename:=jarPath & "\" & image _ 611 | , LinkToFile:=False, SaveWithDocument:=True) 612 | 613 | If fs.FileExists(errorTextFile) Then 614 | image.AlternativeText = LoadTextFile(errorTextFile) 615 | Beep 616 | Else 617 | image.AlternativeText = "Generated by PlantUML" 618 | End If 619 | 620 | If image.ScaleHeight > 100 Or image.ScaleWidth > 100 Then 621 | image.Reset 622 | End If 623 | image = Dir() 624 | Wend 625 | 626 | 'Resume Next 627 | GoTo Phase3 628 | 629 | End Function 630 | 631 | ' ========================================================= 632 | ' Initialize the plantuml ToolBar 633 | Sub ToolbarInit() 634 | On Error Resume Next 635 | ActiveDocument.CommandBars("UML").Delete 636 | On Error GoTo 0 637 | End Sub 638 | 639 | 'doesn't work yet? 640 | 'Callback for customUI.onLoad 641 | Sub RibbonOnLoad(ribbon As IRibbonUI) 642 | End Sub 643 | 644 | 645 | 'original toolbar of plantuml, now obsolete 646 | Function OldToolbarInit() 647 | On Error GoTo ToolbarCreation 648 | Set toolBar = ActiveDocument.CommandBars("UML") 649 | On Error GoTo 0 650 | 651 | toolBar.Visible = True 652 | 653 | On Error GoTo ButtonAdd 654 | Set currentButton = toolBar.Controls(1) 655 | On Error GoTo 0 656 | currentButton.OnAction = "PlantUML.SwitchP" 657 | currentButton.Style = msoButtonCaption 658 | currentButton.Caption = Chr(182) 659 | currentButton.Visible = True 660 | 661 | On Error GoTo ButtonAdd 662 | Set currentButton = toolBar.Controls(2) 663 | On Error GoTo 0 664 | currentButton.OnAction = "PlantUML.ShowPlantuml" 665 | currentButton.Style = msoButtonCaption 666 | currentButton.Caption = "Show PlantUML" 667 | currentButton.Visible = True 668 | 669 | On Error GoTo ButtonAdd 670 | Set currentButton = toolBar.Controls(3) 671 | On Error GoTo 0 672 | currentButton.OnAction = "PlantUML.HidePlantuml" 673 | currentButton.Style = msoButtonCaption 674 | currentButton.Caption = "Hide PlantUML" 675 | currentButton.Visible = True 676 | 677 | On Error GoTo ButtonAdd 678 | Set currentButton = toolBar.Controls(4) 679 | On Error GoTo 0 680 | currentButton.OnAction = "PlantUML.Macro_UML_all" 681 | currentButton.Style = msoButtonCaption 682 | currentButton.Caption = "UML.*" 683 | currentButton.Visible = True 684 | 685 | On Error GoTo ButtonAdd 686 | Set currentButton = toolBar.Controls(5) 687 | On Error GoTo 0 688 | currentButton.OnAction = "PlantUML.Macro_UML_parg" 689 | currentButton.Style = msoButtonCaption 690 | currentButton.Caption = "UML.1" 691 | currentButton.Visible = True 692 | 693 | On Error GoTo ButtonAdd 694 | Set currentButton = toolBar.Controls(6) 695 | On Error GoTo 0 696 | currentButton.OnAction = "" 697 | currentButton.Style = msoButtonCaption 698 | currentButton.Caption = "Trace" 699 | currentButton.Visible = True 700 | Exit Function 701 | 702 | ToolbarCreation: 703 | Set toolBar = ActiveDocument.CommandBars.Add(Name:="UML") 704 | Resume Next 705 | 706 | ButtonAdd: 707 | Set currentButton = toolBar.Controls.Add(Type:=msoControlButton, Before:=toolBar.Controls.Count + 1) 708 | Resume Next 709 | 710 | End Function 711 | 712 | ' ========================================================= 713 | ' We need to double check that the style is present in the document 714 | Function DoubleCheckStyle() 715 | CreateStyle 716 | CreateStyleImg 717 | Set mystyle = ActiveDocument.Styles("PlantUML") 718 | 'myStyle.BaseStyle = ActiveDocument.Styles("Normal") 719 | 'above line fixed to work on international versions of Word 720 | mystyle.BaseStyle = ActiveDocument.Styles(WdBuiltinStyle.wdStyleNormal) 721 | 722 | mystyle.AutomaticallyUpdate = True 723 | With mystyle.Font 724 | .Name = "Courier New" 725 | .Size = 9 726 | .Hidden = False 727 | '.Hidden = True ' change in plantuml template 2.9 to allow copy/paste 728 | .Color = wdColorGreen 729 | End With 730 | End Function 731 | 732 | 733 | ' ========================================================= 734 | Function CreateStyle(Optional overwriteIfStyleExists As Boolean = False) 735 | On Error GoTo CreateStyleAdding 736 | Set mystyle = ActiveDocument.Styles("PlantUML") 737 | If overwriteIfStyleExists = True Then 738 | GoTo CreateStyleOverwrite 739 | End If 740 | Exit Function 741 | CreateStyleAdding: 742 | Set mystyle = ActiveDocument.Styles.Add(Name:="PlantUML", Type:=wdStyleTypeParagraph) 743 | CreateStyleOverwrite: 744 | 'myStyle.BaseStyle = ActiveDocument.Styles("Normal") 745 | ' fix for international versions of Word 746 | mystyle.BaseStyle = ActiveDocument.Styles(WdBuiltinStyle.wdStyleNormal) 747 | mystyle.AutomaticallyUpdate = True 748 | With mystyle.Font 749 | .Name = "Courier New" 750 | .Size = 9 751 | .Hidden = False 752 | .Hidden = True 753 | .Color = wdColorGreen 754 | End With 755 | 756 | mystyle.NoProofing = True 757 | With mystyle.ParagraphFormat 758 | With .Shading 759 | .Texture = wdTextureNone 760 | .ForegroundPatternColor = wdColorAutomatic 761 | .BackgroundPatternColor = wdColorLightGreen 762 | End With 763 | .LineSpacingRule = wdLineSpaceSingle 764 | 'new style: single line, left aligned 765 | .SpaceBefore = 0 766 | .SpaceBeforeAuto = False 767 | .SpaceAfter = 0 768 | .SpaceAfterAuto = False 769 | .LineSpacingRule = wdLineSpaceSingle 770 | .Alignment = wdAlignParagraphLeft 771 | .LineUnitBefore = 0 772 | .LineUnitAfter = 0 773 | .LeftIndent = CentimetersToPoints(0) 774 | 775 | With .Shading 776 | .Texture = wdTextureNone 777 | .ForegroundPatternColor = wdColorAutomatic 778 | .BackgroundPatternColor = 12254650 779 | 780 | End With 781 | With .Borders(wdBorderLeft) 782 | .LineStyle = wdLineStyleDashLargeGap 783 | .LineWidth = wdLineWidth050pt 784 | .Color = 3910491 785 | End With 786 | With .Borders(wdBorderRight) 787 | .LineStyle = wdLineStyleDashLargeGap 788 | .LineWidth = wdLineWidth050pt 789 | .Color = 3910491 790 | End With 791 | With .Borders(wdBorderTop) 792 | .LineStyle = wdLineStyleDashLargeGap 793 | .LineWidth = wdLineWidth050pt 794 | .Color = 3910491 795 | End With 796 | With .Borders(wdBorderBottom) 797 | .LineStyle = wdLineStyleDashLargeGap 798 | .LineWidth = wdLineWidth050pt 799 | .Color = 3910491 800 | End With 801 | With .Borders 802 | .DistanceFromTop = 1 803 | .DistanceFromLeft = 4 804 | .DistanceFromBottom = 1 805 | .DistanceFromRight = 4 806 | .Shadow = False 807 | End With 808 | End With 'paragraphformat 809 | 810 | ' ajout des tabulations 811 | mystyle.NoSpaceBetweenParagraphsOfSameStyle = False 812 | mystyle.ParagraphFormat.TabStops.ClearAll 813 | mystyle.ParagraphFormat.TabStops.Add Position:= _ 814 | CentimetersToPoints(1), Alignment:=wdAlignTabLeft, Leader:=wdTabLeaderSpaces 815 | mystyle.ParagraphFormat.TabStops.Add Position:= _ 816 | CentimetersToPoints(2), Alignment:=wdAlignTabLeft, Leader:=wdTabLeaderSpaces 817 | mystyle.ParagraphFormat.TabStops.Add Position:= _ 818 | CentimetersToPoints(3), Alignment:=wdAlignTabLeft, Leader:=wdTabLeaderSpaces 819 | mystyle.ParagraphFormat.TabStops.Add Position:= _ 820 | CentimetersToPoints(4), Alignment:=wdAlignTabLeft, Leader:=wdTabLeaderSpaces 821 | 822 | 823 | End Function 824 | 825 | ' ========================================================= 826 | Function CreateStyleImg() 827 | 828 | On Error GoTo CreateStyleImgAdding 829 | Set mystyle = ActiveDocument.Styles("PlantUMLImg") 830 | mystyle.Font.Hidden = False 831 | On Error GoTo CreateStyleSkip 832 | mystyle.BaseStyle = ActiveDocument.Styles("Normal") 833 | CreateStyleSkip: 834 | On Error GoTo 0 835 | Exit Function 836 | CreateStyleImgAdding: 837 | Set mystyle = ActiveDocument.Styles.Add(Name:="PlantUMLImg", Type:=wdStyleTypeParagraph) 838 | mystyle.AutomaticallyUpdate = True 839 | End Function 840 | 841 | ' ========================================================= 842 | ' We show the hidden text 843 | Function ShowPlantuml() 844 | DoubleCheckStyle 845 | 846 | 'WordBasic.ShowComments 847 | ' We put a bookmark to retrieve position after showing the text 848 | ActiveDocument.Bookmarks.Add Name:="Position", Range:=Selection.Range 849 | 850 | Set mystyle = ActiveDocument.Styles("PlantUML") 851 | ' Set toolBar = ActiveDocument.CommandBars("UML") 852 | 853 | ' toolBar.Controls(2).Visible = False 854 | ' toolBar.Controls(3).Visible = True 855 | ' toolBar.Controls(4).Visible = True 856 | ' toolBar.Controls(5).Visible = True 857 | 858 | Call ShowHiddenText 859 | 860 | 'We go back to the bookmark and we delete it 861 | Selection.GoTo What:=wdGoToBookmark, Name:="Position" 862 | ActiveDocument.Bookmarks(Index:="Position").Delete 863 | 864 | End Function 865 | 866 | 867 | ' ========================================================= 868 | ' MSR - management of display/hide text with style "PlantUML" 869 | Function HidePlantuml() 870 | DoubleCheckStyle 871 | 'WordBasic.ShowComments 872 | ' We put a bookmark to retrieve position after showing the text 873 | ActiveDocument.Bookmarks.Add Name:="Position", Range:=Selection.Range 874 | 875 | Set mystyle = ActiveDocument.Styles("PlantUML") 876 | ' Set toolBar = ActiveDocument.CommandBars("UML") 877 | 878 | ' toolBar.Controls(2).Visible = True 879 | ' toolBar.Controls(3).Visible = False 880 | ' toolBar.Controls(4).Visible = False 881 | ' toolBar.Controls(5).Visible = False 882 | 883 | Call HideHiddenText 884 | 885 | 'We go back to the bookmark and we delete it 886 | Selection.GoTo What:=wdGoToBookmark, Name:="Position" 887 | ActiveDocument.Bookmarks(Index:="Position").Delete 888 | 889 | End Function 890 | 891 | ' ========================================================= 892 | Function HideHiddenText() 893 | ActiveDocument.ActiveWindow.View.ShowAll = False 894 | ActiveDocument.ActiveWindow.View.ShowHiddenText = False 895 | On Error GoTo endHidden 896 | With ActiveDocument.Styles("PlantUML") 897 | .Font.Hidden = True 898 | End With 899 | endHidden: 900 | On Error Resume Next 901 | End Function 902 | 903 | ' ========================================================= 904 | Function ShowHiddenText() 905 | ActiveDocument.ActiveWindow.View.ShowAll = False 906 | ActiveDocument.ActiveWindow.View.ShowHiddenText = True 907 | 908 | On Error GoTo endShow 909 | With ActiveDocument.Styles("PlantUML") 910 | .Font.Hidden = False 911 | End With 912 | endShow: 913 | On Error Resume Next 914 | End Function 915 | 916 | ' ========================================================= 917 | Function SwitchP() 918 | flag = Not (ActiveDocument.ActiveWindow.View.ShowTabs) 919 | ActiveDocument.ActiveWindow.View.ShowParagraphs = flag 920 | ActiveDocument.ActiveWindow.View.ShowTabs = flag 921 | ActiveDocument.ActiveWindow.View.ShowSpaces = flag 922 | ActiveDocument.ActiveWindow.View.ShowHyphens = flag 923 | ActiveDocument.ActiveWindow.View.ShowAll = False 924 | End Function 925 | 926 | ' ========================================================= 927 | ' \\ Function to return the full content of a text file as a string 928 | 'from http://www.vbaexpress.com/kb/getarticle.php?kb_id=699 929 | Function LoadTextFile(sFile) As String 930 | Dim iFile As Integer 931 | 932 | On Local Error Resume Next 933 | ' \\ Use FreeFile to supply a file number that is not already in use 934 | iFile = FreeFile 935 | 936 | ' \\ ' Open file for input. 937 | Open sFile For Input As #iFile 938 | 939 | ' \\ Return (Read) the whole content of the file to the function 940 | LoadTextFile = Input$(LOF(iFile), iFile) 941 | 942 | Close #iFile 943 | 944 | End Function 945 | 946 | 947 | 948 | Sub ISwitchP(ByVal Control As IRibbonControl) 949 | SwitchP 950 | End Sub 951 | 952 | Sub IShowPlantUML(ByVal Control As IRibbonControl) 953 | ShowPlantuml 954 | 955 | End Sub 956 | 957 | Sub IHidePlantUML(ByVal Control As IRibbonControl) 958 | HidePlantuml 959 | 960 | End Sub 961 | 962 | Sub IUML1(ByVal Control As IRibbonControl) 963 | Macro_UML ("parg") 964 | 965 | End Sub 966 | Sub IUMLAll(ByVal Control As IRibbonControl) 967 | Macro_UML ("all") 968 | End Sub 969 | 970 | Sub IAutoFormatOn(ByVal Control As IRibbonControl) 971 | AutoFormatOn 972 | End Sub 973 | Sub IAutoFormatOff(ByVal Control As IRibbonControl) 974 | AutoFormatOff 975 | End Sub 976 | 977 | Sub IPlantUMLInteractive(ByVal Control As IRibbonControl) 978 | With frmPlantUMLInteractive 979 | 980 | 981 | .tbPlantCode.Text = Replace(Macro_UML("fetch"), vbLf, vbCrLf) 982 | 983 | .Show 984 | 985 | End With 986 | 987 | End Sub 988 | 989 | 990 | 991 | 992 | 993 | Sub IPreferences(ByVal Control As IRibbonControl) 994 | Dim info As String 995 | info = "Microsoft Word 2010 addin by Adriaan van den Brand" & vbCrLf & _ 996 | "Plantuml: see http://plantuml.com" & vbCrLf & _ 997 | "Graphviz path: " & getDotPath() & vbCrLf & _ 998 | "Plantuml JAR: " & getJarPath() 999 | 1000 | If RegKeyRead("VectorGraphics") = "ON" Then 1001 | vectorgraphics = True 1002 | End If 1003 | If RegKeyRead("FTPMode") = "ON" Then 1004 | useFTP = True 1005 | End If 1006 | FTPURL = RegKeyRead("URL") 1007 | 1008 | With PrefsForm 1009 | If vectorgraphics = True Then 1010 | .btnVectorGraphics.Caption = "ON" 1011 | Else 1012 | .btnVectorGraphics.Caption = "OFF" 1013 | End If 1014 | If useFTP = True Then 1015 | .btnFTP.Caption = "ON" 1016 | Else 1017 | .btnFTP.Caption = "OFF" 1018 | End If 1019 | 1020 | .info.Caption = info 1021 | .Show 1022 | RegKeySave "VectorGraphics", .btnVectorGraphics.Caption 1023 | RegKeySave "FTPMode", .btnFTP.Caption 1024 | RegKeySave "FTPURL", .tbURL.Text 1025 | 1026 | ' adjust setting, will even work if registry saving failed 1027 | vectorgraphics = (.btnVectorGraphics.Caption = "ON") 1028 | useFTP = (.btnFTP.Caption = "ON") 1029 | FTPURL = (.tbURL.Text) 1030 | 1031 | End With 1032 | End Sub 1033 | 1034 | Sub AutoFormatOff() 1035 | ' disable worst of MS Word autoformatting options 1036 | With options 1037 | .AutoFormatAsYouTypeReplaceQuotes = False 1038 | .AutoFormatAsYouTypeReplaceSymbols = False 1039 | .AutoFormatAsYouTypeReplacePlainTextEmphasis = False 1040 | .AutoFormatAsYouTypeDefineStyles = False 1041 | .TabIndentKey = True 1042 | End With 1043 | End Sub 1044 | 1045 | Sub AutoFormatOn() 1046 | ' enable disabled MS Word autoformatting options 1047 | With options 1048 | .AutoFormatAsYouTypeReplaceQuotes = True 1049 | .AutoFormatAsYouTypeReplaceSymbols = True 1050 | .AutoFormatAsYouTypeReplacePlainTextEmphasis = True 1051 | .AutoFormatAsYouTypeDefineStyles = True 1052 | .TabIndentKey = True 1053 | End With 1054 | End Sub 1055 | 1056 | 1057 | -------------------------------------------------------------------------------- /Template_Word_2010_2013/module/PlantumlFTP: -------------------------------------------------------------------------------- 1 | Const ASCII_TRANSFER = 1 2 | Const BINARY_TRANSFER = 2 3 | Const INTERNET_FLAG_RELOAD = &H80000000 4 | Const UserName = "plantuml" 5 | Const Pass = "plantuml" 6 | Const useFTP = True 7 | 8 | 'Open the Internet object 9 | Private Declare Function InternetOpen _ 10 | Lib "wininet.dll" _ 11 | Alias "InternetOpenA" _ 12 | (ByVal sAgent As String, _ 13 | ByVal lAccessType As Long, _ 14 | ByVal sProxyName As String, _ 15 | ByVal sProxyBypass As String, _ 16 | ByVal lFlags As Long) As Long 17 | 18 | 'Connect to the network 19 | Private Declare Function InternetConnect _ 20 | Lib "wininet.dll" _ 21 | Alias "InternetConnectA" _ 22 | (ByVal hInternetSession As Long, _ 23 | ByVal sServerName As String, _ 24 | ByVal nServerPort As Integer, _ 25 | ByVal sUsername As String, _ 26 | ByVal sPassword As String, _ 27 | ByVal lService As Long, _ 28 | ByVal lFlags As Long, _ 29 | ByVal lContext As Long) As Long 30 | 31 | 'Get a file using FTP 32 | Private Declare Function FtpGetFile _ 33 | Lib "wininet.dll" _ 34 | Alias "FtpGetFileA" _ 35 | (ByVal hFtpSession As Long, _ 36 | ByVal lpszRemoteFile As String, _ 37 | ByVal lpszNewFile As String, _ 38 | ByVal fFailIfExists As Boolean, _ 39 | ByVal dwFlagsAndAttributes As Long, _ 40 | ByVal dwFlags As Long, _ 41 | ByVal dwContext As Long) As Boolean 42 | 43 | 'Send a file using FTP 44 | Private Declare Function FtpPutFile _ 45 | Lib "wininet.dll" _ 46 | Alias "FtpPutFileA" _ 47 | (ByVal hFtpSession As Long, _ 48 | ByVal lpszLocalFile As String, _ 49 | ByVal lpszRemoteFile As String, _ 50 | ByVal dwFlags As Long, _ 51 | ByVal dwContext As Long) As Boolean 52 | 53 | 'Close the Internet object 54 | Private Declare Function InternetCloseHandle _ 55 | Lib "wininet.dll" _ 56 | (ByVal hInet As Long) As Integer 57 | 58 | 59 | Function testgetServerPort() 60 | Dim servername As String 61 | Dim serverport As Integer 62 | serverport = 123 63 | Debug.Assert getServerPort("127.0.0.1", servername, serverport) = True 64 | Debug.Assert servername = "127.0.0.1" 65 | Debug.Assert serverport = 123 66 | 67 | 68 | Debug.Assert getServerPort("127.0.0.1:4242", servername, serverport) = True 69 | Debug.Assert servername = "127.0.0.1" 70 | Debug.Assert serverport = 4242 71 | servername = "" 72 | serverport = 4242 73 | Debug.Assert getServerPort("127.0.0.1", servername, serverport) = True 74 | Debug.Assert servername = "127.0.0.1" 75 | Debug.Assert serverport = 4242 76 | 77 | Debug.Assert getServerPort("http://127.0.0.1:4242", servername, serverport) = False 78 | Debug.Assert getServerPort("www.nowhere.com:1234", servername, serverport) = True 79 | Debug.Assert servername = "www.nowhere.com" 80 | Debug.Assert serverport = 1234 81 | 82 | 83 | End Function 84 | 85 | Function getServerPort(url As String, ByRef servername As String, ByRef serverport As Integer) As Boolean 86 | Dim params() As String 87 | Dim RE As RegExp 88 | Dim match 89 | getServerPort = False 90 | Set RE = New RegExp 91 | url = LCase(url) 92 | If InStr("://", url) Then 93 | If Left(url, 6) = "ftp://" Then 94 | url = Mid(url, 7) 95 | Else 96 | Exit Function 97 | End If 98 | End If 99 | 100 | params = Split(url, ":") 101 | If UBound(params) <= 1 Then 102 | servername = params(0) 103 | If UBound(params) = 1 Then 104 | serverport = Val(params(1)) 105 | End If 106 | RE.Pattern = "[^:/\\ \t\n\r\%\&]+" 107 | If RE.Test(servername) And ((UBound(params) = 0) Or (serverport > 0)) Then 108 | getServerPort = True 109 | End If 110 | End If 111 | End Function 112 | 113 | Function ftpOpen(FTPURL As String) As Long 114 | Dim INet As Long 115 | Dim INetConn As Long 116 | Dim RetVal As Long 117 | Dim Success As Long 118 | Dim servername As String 119 | Dim serverport As Integer 120 | ftpOpen = 0 121 | INetConn = -1 122 | serverport = 4242 ' default 123 | If getServerPort(FTPURL, servername, serverport) Then 124 | 125 | INet = InternetOpen("MyFTP Control", 1&, vbNullString, vbNullString, 0&) 126 | If INet > 0 Then 127 | INetConn = InternetConnect(INet, servername, serverport, UserName, Pass, 1&, 0&, 0&) 128 | ftpOpen = INetConn 129 | Debug.Print "FtpOpen(" & FTPURL & ") -> success" 130 | Else 131 | Debug.Print "FtpOpen(" & FTPURL & ") -> failed" 132 | End If 133 | Else 134 | Debug.Print "FtpOpen(" & FTPURL & ") -> ill configured server/port" 135 | End If 136 | End Function 137 | 138 | Function ftpClose(handle As Long) 139 | If handle > 0 Then 140 | RetVal = InternetCloseHandle(handle) 141 | End If 142 | Debug.Print "FtpClose(" & handle & ")" 143 | End Function 144 | ' ========================================================= 145 | ' Store a File to a FTP server 146 | Function FtpStor(INetConn As Long, localFile, hostFile) 147 | 148 | Dim RetVal As Long 149 | Dim Success As Long 150 | 151 | RetVal = False 152 | FtpStor = True 153 | 154 | If INetConn > 0 Then 155 | Success = FtpPutFile(INetConn, localFile, hostFile, BINARY_TRANSFER Or INTERNET_FLAG_RELOAD, 0&) 156 | FtpStor = True 157 | End If 158 | Debug.Print "FtpStor(" & localFile & " , " & hostFile & ") -> " & RetVal & "success=" & Success 159 | 160 | End Function 161 | 162 | 163 | ' ========================================================= 164 | ' Retrieve a File from a FTP server 165 | Function FtpRetr(INetConn As Long, localFile, hostFile) 166 | 167 | Dim INet As Long 168 | Dim RetVal As Long 169 | Dim Success As Long 170 | 171 | RetVal = False 172 | FtpRetr = RetVal 173 | If INetConn > 0 Then 174 | FtpRetr = True 175 | Success = FtpGetFile(INetConn, hostFile, localFile, False, 0, BINARY_TRANSFER Or INTERNET_FLAG_RELOAD, 0&) 176 | Debug.Print "FtpRetr(" & localFile & " , " & hostFile & ") -> " & Success 177 | 178 | End If 179 | 180 | End Function 181 | 182 | 183 | 184 | 185 | ' ========================================================= 186 | 187 | Function Macro_UML(scope) 188 | ' Generate diagrams image from a PlantUML source textual description in the Word Document 189 | ' Scope can be "parg" or "all" 190 | ' 191 | ' - Initialisations 192 | ' 193 | Call ToolbarInit 194 | Set statusButton = CommandBars("UML").Controls(6) 195 | 196 | Call CreateStyle 197 | Call CreateStyleImg 198 | Call ShowPlantuml 199 | 200 | Call ShowHiddenText 201 | Selection.Range.Select 202 | ' 203 | ' documentId is the filename with its path, without extension 204 | ' 205 | documentId = ActiveDocument.Name 206 | documentId = Left(documentId, Len(documentId) - 4) 207 | 208 | ' Check for the presente of plantuml.jar 209 | 210 | Set fs = CreateObject("Scripting.FileSystemObject") 211 | jarPath = getJarPath() 212 | If fs.FileExists(jarPath & "\plantuml.jar") = False Then 213 | MsgBox jarPath 214 | GoTo Macro_UML_exit 215 | End If 216 | 217 | ' - Phase 1 218 | ' We create a file text per bloc of diagrams 219 | ' We look for @startuml 220 | ' We open the textfile in background (visible:=false) 221 | ' We add to the name a number on 4 digit 222 | ' The text bloc is put on "PlantUML" style 223 | ' Then the bloc is copied into the text file 224 | 225 | statusButton.Caption = "Extract" 226 | statusButton.Visible = False 227 | statusButton.Visible = True 228 | If scope = "all" Then 229 | Set parsedtext = ActiveDocument.Content 230 | isForward = True 231 | Else 232 | Set parsedtext = Selection.Range 233 | parsedtext.Collapse 234 | isForward = False 235 | End If 236 | 237 | parsedtext.Find.Execute FindText:=startuml, Forward:=isForward 238 | If parsedtext.Find.Found = True Then 239 | 'We keep the the first line only "@startuml" with the carriage return 240 | Set singleparagraph = parsedtext.Paragraphs(1).Range 241 | singleparagraph.Collapse 242 | Else 243 | GoTo Macro_UML_exit 244 | End If 245 | 246 | Do While parsedtext.Find.Found = True And _ 247 | (scope = "all" Or currentIndex < 1) 248 | statusButton.Caption = "Extract." & currentIndex + 1 249 | statusButton.Visible = False 250 | statusButton.Visible = True 251 | Set currentparagraph = parsedtext.Paragraphs(1) 252 | Set paragraphRange = currentparagraph.Range 253 | paragraphRange.Collapse 254 | jobDone = False 255 | Do Until jobDone 256 | If Left(currentparagraph.Range.Text, Len(startuml)) = startuml Then 257 | Set paragraphRange = currentparagraph.Range 258 | paragraphRange.Collapse 259 | 260 | End If 261 | paragraphRange.MoveEnd Unit:=wdParagraph 262 | If Left(currentparagraph.Range.Text, Len(enduml)) = enduml Then 263 | paragraphRange.Style = "PlantUML" 264 | paragraphRange.Copy 265 | Set textFile = Documents.Add(Visible:=False) 266 | textFile.Content.Paste 267 | currentIndex = currentIndex + 1 268 | textFileId = documentId & "_extr" & Right("000" & currentIndex, 4) & ".txt" 269 | textFile.SaveAs filename:=jarPath & "\" & textFileId, FileFormat:=wdFormatText, Encoding:=65001 270 | textFile.Close 271 | If useFTP Then 272 | retValue = FtpStor(jarPath & "\" & textFileId, textFileId) 273 | 'MsgBox ("A") 274 | 'imageId = Left(textFileId, Len(textFileId) - 4) & ".png" 275 | 'imageName = jarPath & "\" & imageId 276 | 'retValue = FtpRetr(imageName, imageId) 277 | 'MsgBox ("B") 278 | End If 279 | jobDone = True 280 | End If 281 | 282 | Set currentparagraph = currentparagraph.Next 283 | 284 | If currentparagraph Is Nothing Then 285 | jobDone = True 286 | End If 287 | Loop 288 | parsedtext.Collapse Direction:=wdCollapseEnd 289 | If scope = "all" Then 290 | parsedtext.Find.Execute FindText:=startuml, Forward:=True 291 | End If 292 | Loop 293 | ' 294 | ' We create a lock file that will be deleted by the Java program to indicate the end of Java process 295 | ' 296 | statusButton.Caption = "Gener" 297 | statusButton.Visible = False 298 | statusButton.Visible = True 299 | Set lockFile = Documents.Add(Visible:=False) 300 | lockFile.SaveAs filename:=jarPath & "\javaumllock.tmp", FileFormat:=wdFormatText 301 | lockFile.Close 302 | 303 | ' 304 | ' Call to PlantUML to generate images from text descriptions 305 | ' 306 | If useFTP Then 307 | For I = 1 To currentIndex 308 | imageId = documentId & "_extr" & Right("000" & I, 4) & ".png" 309 | imageName = jarPath & "\" & imageId 310 | retValue = FtpRetr(imageName, imageId) 311 | Next I 312 | 'Sleep 200 313 | End If 314 | 315 | If useFTP = False Then 316 | JavaCommand = "java -classpath """ & jarPath & "\plantuml.jar;" & _ 317 | jarPath & "\plantumlskins.jar"" net.sourceforge.plantuml.Run -charset UTF8 -word """ & jarPath & "/""" 318 | Shell (JavaCommand) 319 | ' This sleep is needed, but we don't know why... 320 | Sleep 500 321 | ' 322 | ' Phase 2 : 323 | ' Insertion of images into the word document 324 | ' We insert the image after the textual block that describe the diagram 325 | ' 326 | jobDone = False 327 | currentIndex = 0 328 | 329 | ' We wait for the file javaumllock.tmp to be deleted by Java 330 | ' which means that the process is ended 331 | ' 332 | Do 333 | currentIndex = currentIndex + 1 334 | statusButton.Caption = "Gener." & currentIndex 335 | statusButton.Visible = False 336 | statusButton.Visible = True 337 | DoEvents 338 | Sleep 1000 339 | If fs.FileExists(jarPath & "\javaumllock.tmp") = False Then 340 | jobDone = True 341 | Exit Do 342 | End If 343 | If currentIndex > 30 Then 344 | statusButton.Visible = False 345 | MsgBox ("Java Timeout. Aborted.") 346 | Exit Do 347 | End If 348 | Loop 349 | 350 | If jobDone = False Then 351 | End 352 | End If 353 | End If 354 | 355 | statusButton.Caption = "Inser" 356 | statusButton.Visible = False 357 | statusButton.Visible = True 358 | 359 | If scope = "all" Then 360 | Set parsedtext = ActiveDocument.Content 361 | isForward = True 362 | Else 363 | Set parsedtext = singleparagraph 364 | isForward = True 365 | End If 366 | parsedtext.Find.Execute FindText:=enduml, Forward:=isForward 367 | currentIndex = 0 368 | Do While parsedtext.Find.Found = True And (scope = "all" Or currentIndex < 1) 369 | currentIndex = currentIndex + 1 370 | statusButton.Caption = "Inser." & currentIndex 371 | statusButton.Visible = False 372 | statusButton.Visible = True 373 | On Error GoTo LastParagraph 374 | Set currentparagraph = parsedtext.Paragraphs(1).Next.Range 375 | Do While currentparagraph.InlineShapes.Count > 0 And currentparagraph.Style = "PlantUMLImg" 376 | currentparagraph.Delete 377 | Set currentparagraph = parsedtext.Paragraphs(1).Next.Range 378 | Loop 379 | On Error GoTo 0 380 | Set currentRange = currentparagraph 381 | imagesDirectory = jarPath & "\" & documentId & "_extr" & Right("000" & currentIndex, 4) & "*.png" 382 | image = Dir(imagesDirectory) 383 | While image <> "" 384 | Set currentparagraph = ActiveDocument.Paragraphs.Add(Range:=currentRange).Range 385 | Set currentRange = currentparagraph.Paragraphs(1).Next.Range 386 | currentparagraph.Style = "PlantUMLImg" 387 | currentparagraph.Collapse 388 | 389 | Set image = currentparagraph.InlineShapes.AddPicture _ 390 | (filename:=jarPath & "\" & image _ 391 | , LinkToFile:=False, SaveWithDocument:=True) 392 | image.AlternativeText = "Generated by PlantUML" 393 | If image.ScaleHeight > 100 Or image.ScaleWidth > 100 Then 394 | image.Reset 395 | End If 396 | image = Dir() 397 | Wend 398 | parsedtext.Collapse Direction:=wdCollapseEnd 399 | parsedtext.Find.Execute FindText:=enduml, Forward:=True 400 | Loop 401 | 402 | ' 403 | ' Phase 3 : suppression of temporary files (texte and PNG) 404 | ' 405 | Phase3: 406 | statusButton.Caption = "Delete" 407 | statusButton.Visible = False 408 | statusButton.Visible = True 409 | On Error Resume Next 410 | Kill (jarPath & "\" & documentId & "_extr*.*") 411 | On Error GoTo 0 412 | 413 | Macro_UML_exit: 414 | 415 | statusButton.Visible = False 416 | 417 | 'We show the hidden description text 418 | Call ShowHiddenText 419 | DoubleCheckStyle 420 | Exit Function 421 | 422 | 423 | ' This is need when the very last line of the Word document is @enduml 424 | LastParagraph: 425 | Selection.EndKey Unit:=wdStory 426 | Selection.TypeParagraph 427 | Selection.ClearFormatting 428 | 429 | imagesDirectory = jarPath & "\" & documentId & "_extr" & Right("000" & currentIndex, 4) & "*.png" 430 | image = Dir(imagesDirectory) 431 | While image <> "" 432 | Set currentparagraph = ActiveDocument.Paragraphs.Add.Range 433 | Set currentRange = currentparagraph.Paragraphs(1).Next.Range 434 | currentparagraph.Style = "PlantUMLImg" 435 | currentparagraph.Collapse 436 | 437 | Set image = currentparagraph.InlineShapes.AddPicture _ 438 | (filename:=jarPath & "\" & image _ 439 | , LinkToFile:=False, SaveWithDocument:=True) 440 | image.AlternativeText = "Generated by PlantUML" 441 | If image.ScaleHeight > 100 Or image.ScaleWidth > 100 Then 442 | image.Reset 443 | End If 444 | image = Dir() 445 | Wend 446 | 447 | 'Resume Next 448 | GoTo Phase3 449 | 450 | End Function 451 | 452 | ' ========================================================= 453 | ' Initialize the plantuml ToolBar 454 | Function ToolbarInit() 455 | 456 | On Error GoTo ToolbarCreation 457 | Set toolBar = ActiveDocument.CommandBars("UML") 458 | On Error GoTo 0 459 | toolBar.Visible = True 460 | 461 | On Error GoTo ButtonAdd 462 | Set currentButton = toolBar.Controls(1) 463 | On Error GoTo 0 464 | currentButton.OnAction = "Module1.SwitchP" 465 | currentButton.Style = msoButtonCaption 466 | currentButton.Caption = Chr(182) 467 | currentButton.Visible = True 468 | 469 | On Error GoTo ButtonAdd 470 | Set currentButton = toolBar.Controls(2) 471 | On Error GoTo 0 472 | currentButton.OnAction = "Module1.ShowPlantuml" 473 | currentButton.Style = msoButtonCaption 474 | currentButton.Caption = "Show PlantUML" 475 | currentButton.Visible = True 476 | 477 | On Error GoTo ButtonAdd 478 | Set currentButton = toolBar.Controls(3) 479 | On Error GoTo 0 480 | currentButton.OnAction = "Module1.HidePlantuml" 481 | currentButton.Style = msoButtonCaption 482 | currentButton.Caption = "Hide PlantUML" 483 | currentButton.Visible = True 484 | 485 | On Error GoTo ButtonAdd 486 | Set currentButton = toolBar.Controls(4) 487 | On Error GoTo 0 488 | currentButton.OnAction = "Module1.Macro_UML_all" 489 | currentButton.Style = msoButtonCaption 490 | currentButton.Caption = "UML.*" 491 | currentButton.Visible = True 492 | 493 | On Error GoTo ButtonAdd 494 | Set currentButton = toolBar.Controls(5) 495 | On Error GoTo 0 496 | currentButton.OnAction = "Module1.Macro_UML_parg" 497 | currentButton.Style = msoButtonCaption 498 | currentButton.Caption = "UML.1" 499 | currentButton.Visible = True 500 | 501 | On Error GoTo ButtonAdd 502 | Set currentButton = toolBar.Controls(6) 503 | On Error GoTo 0 504 | currentButton.OnAction = "" 505 | currentButton.Style = msoButtonCaption 506 | currentButton.Caption = "Trace" 507 | currentButton.Visible = True 508 | Exit Function 509 | 510 | ToolbarCreation: 511 | Set toolBar = ActiveDocument.CommandBars.Add(Name:="UML") 512 | Resume Next 513 | 514 | ButtonAdd: 515 | Set currentButton = toolBar.Controls.Add(Type:=msoControlButton, Before:=toolBar.Controls.Count + 1) 516 | Resume Next 517 | 518 | End Function 519 | 520 | ' ========================================================= 521 | ' We need to double check that the style is present in the document 522 | Function DoubleCheckStyle() 523 | CreateStyle 524 | CreateStyleImg 525 | Set mystyle = ActiveDocument.Styles("PlantUML") 526 | mystyle.BaseStyle = ActiveDocument.Styles.Item(1).BaseStyle 527 | 528 | mystyle.AutomaticallyUpdate = True 529 | With mystyle.Font 530 | .Name = "Courier New" 531 | .Size = 9 532 | .Hidden = False 533 | .Hidden = True 534 | .Color = wdColorGreen 535 | End With 536 | End Function 537 | 538 | ' ========================================================= 539 | Function CreateStyle() 540 | On Error GoTo CreateStyleAdding 541 | Set mystyle = ActiveDocument.Styles("PlantUML") 542 | Exit Function 543 | CreateStyleAdding: 544 | Set mystyle = ActiveDocument.Styles.Add(Name:="PlantUML", Type:=wdStyleTypeParagraph) 545 | mystyle.BaseStyle = ActiveDocument.Styles.Item(1).BaseStyle 546 | mystyle.AutomaticallyUpdate = True 547 | With mystyle.Font 548 | .Name = "Courier New" 549 | .Size = 9 550 | .Hidden = False 551 | .Hidden = True 552 | .Color = wdColorGreen 553 | End With 554 | With mystyle.ParagraphFormat 555 | With .Shading 556 | .Texture = wdTextureNone 557 | .ForegroundPatternColor = wdColorAutomatic 558 | .BackgroundPatternColor = wdColorLightGreen 559 | End With 560 | 561 | .LeftIndent = CentimetersToPoints(0) 562 | With .Shading 563 | .Texture = wdTextureNone 564 | .ForegroundPatternColor = wdColorAutomatic 565 | .BackgroundPatternColor = 12254650 566 | End With 567 | With .Borders(wdBorderLeft) 568 | .LineStyle = wdLineStyleDashLargeGap 569 | .LineWidth = wdLineWidth050pt 570 | .Color = 3910491 571 | End With 572 | With .Borders(wdBorderRight) 573 | .LineStyle = wdLineStyleDashLargeGap 574 | .LineWidth = wdLineWidth050pt 575 | .Color = 3910491 576 | End With 577 | With .Borders(wdBorderTop) 578 | .LineStyle = wdLineStyleDashLargeGap 579 | .LineWidth = wdLineWidth050pt 580 | .Color = 3910491 581 | End With 582 | With .Borders(wdBorderBottom) 583 | .LineStyle = wdLineStyleDashLargeGap 584 | .LineWidth = wdLineWidth050pt 585 | .Color = 3910491 586 | End With 587 | With .Borders 588 | .DistanceFromTop = 1 589 | .DistanceFromLeft = 4 590 | .DistanceFromBottom = 1 591 | .DistanceFromRight = 4 592 | .Shadow = False 593 | End With 594 | End With 595 | 596 | ' ajout des tabulations 597 | mystyle.NoSpaceBetweenParagraphsOfSameStyle = False 598 | mystyle.ParagraphFormat.TabStops.ClearAll 599 | mystyle.ParagraphFormat.TabStops.Add Position:= _ 600 | CentimetersToPoints(1), Alignment:=wdAlignTabLeft, Leader:=wdTabLeaderSpaces 601 | mystyle.ParagraphFormat.TabStops.Add Position:= _ 602 | CentimetersToPoints(2), Alignment:=wdAlignTabLeft, Leader:=wdTabLeaderSpaces 603 | mystyle.ParagraphFormat.TabStops.Add Position:= _ 604 | CentimetersToPoints(3), Alignment:=wdAlignTabLeft, Leader:=wdTabLeaderSpaces 605 | mystyle.ParagraphFormat.TabStops.Add Position:= _ 606 | CentimetersToPoints(4), Alignment:=wdAlignTabLeft, Leader:=wdTabLeaderSpaces 607 | 608 | 609 | End Function 610 | 611 | ' ========================================================= 612 | Function CreateStyleImg() 613 | On Error GoTo CreateStyleImgAdding 614 | Set mystyle = ActiveDocument.Styles("PlantUMLImg") 615 | mystyle.BaseStyle = ActiveDocument.Styles.Item(1).BaseStyle 616 | On Error GoTo 0 617 | Exit Function 618 | CreateStyleImgAdding: 619 | Set mystyle = ActiveDocument.Styles.Add(Name:="PlantUMLImg", Type:=wdStyleTypeParagraph) 620 | mystyle.AutomaticallyUpdate = True 621 | End Function 622 | 623 | ' ========================================================= 624 | ' We show the hidden text 625 | Function ShowPlantuml() 626 | DoubleCheckStyle 627 | 628 | 'WordBasic.ShowComments 629 | ' We put a bookmark to retrieve position after showing the text 630 | ActiveDocument.Bookmarks.Add Name:="Position", Range:=Selection.Range 631 | 632 | Set mystyle = ActiveDocument.Styles("PlantUML") 633 | Set toolBar = ActiveDocument.CommandBars("UML") 634 | 635 | toolBar.Controls(2).Visible = False 636 | toolBar.Controls(3).Visible = True 637 | toolBar.Controls(4).Visible = True 638 | toolBar.Controls(5).Visible = True 639 | 640 | Call ShowHiddenText 641 | 642 | 'We go back to the bookmark and we delete it 643 | Selection.GoTo What:=wdGoToBookmark, Name:="Position" 644 | ActiveDocument.Bookmarks(Index:="Position").Delete 645 | 646 | End Function 647 | 648 | 649 | ' ========================================================= 650 | ' MSR - gestion de l'option d'affichage des textes masques du style : "PlantUML" 651 | Function HidePlantuml() 652 | DoubleCheckStyle 653 | 'WordBasic.ShowComments 654 | ' We put a bookmark to retrieve position after showing the text 655 | ActiveDocument.Bookmarks.Add Name:="Position", Range:=Selection.Range 656 | 657 | Set mystyle = ActiveDocument.Styles("PlantUML") 658 | Set toolBar = ActiveDocument.CommandBars("UML") 659 | 660 | toolBar.Controls(2).Visible = True 661 | toolBar.Controls(3).Visible = False 662 | toolBar.Controls(4).Visible = False 663 | toolBar.Controls(5).Visible = False 664 | 665 | Call HideHiddenText 666 | 667 | 'We go back to the bookmark and we delete it 668 | Selection.GoTo What:=wdGoToBookmark, Name:="Position" 669 | ActiveDocument.Bookmarks(Index:="Position").Delete 670 | 671 | End Function 672 | 673 | ' ========================================================= 674 | Function HideHiddenText() 675 | ActiveDocument.ActiveWindow.View.ShowAll = False 676 | ActiveDocument.ActiveWindow.View.ShowHiddenText = False 677 | End Function 678 | 679 | ' ========================================================= 680 | Function ShowHiddenText() 681 | ActiveDocument.ActiveWindow.View.ShowAll = False 682 | ActiveDocument.ActiveWindow.View.ShowHiddenText = True 683 | End Function 684 | 685 | ' ========================================================= 686 | Function SwitchP() 687 | flag = Not (ActiveDocument.ActiveWindow.View.ShowTabs) 688 | ActiveDocument.ActiveWindow.View.ShowParagraphs = flag 689 | ActiveDocument.ActiveWindow.View.ShowTabs = flag 690 | ActiveDocument.ActiveWindow.View.ShowSpaces = flag 691 | ActiveDocument.ActiveWindow.View.ShowHyphens = flag 692 | ActiveDocument.ActiveWindow.View.ShowAll = False 693 | End Function 694 | 695 | 696 | 697 | 698 | 699 | 700 | -------------------------------------------------------------------------------- /Template_Word_2010_2013/module/Registry: -------------------------------------------------------------------------------- 1 | 'from http://www.slipstick.com/developer/read-and-change-a-registry-key-using-vba/ 2 | 3 | 4 | Public Const basekey = "HKEY_CURRENT_USER\Software\PlantUML\" 5 | 'reads the value for the registry key i_RegKey 6 | 'if the key cannot be found, the return value is "" 7 | Function RegKeyRead(i_RegKey As String, Optional default As String) As String 8 | On Error Resume Next 9 | Dim myWS As Object 10 | If IsMissing(default) Then 11 | default = "" 12 | End If 13 | If Not RegKeyExists(basekey & i_RegKey) Then 14 | RegKeySave i_RegKey, default, "REG_SZ" 15 | End If 16 | On Error Resume Next 17 | 'access Windows scripting 18 | Set myWS = CreateObject("WScript.Shell") 19 | 'read key from registry 20 | RegKeyRead = myWS.RegRead(basekey & i_RegKey) 21 | On Error GoTo 0 22 | End Function 23 | 24 | 'sets the registry key i_RegKey to the 25 | 'value i_Value with type i_Type 26 | 'if i_Type is omitted, the value will be saved as string 27 | 'if i_RegKey wasn't found, a new registry key will be created 28 | 29 | ' change REG_DWORD to the correct key type 30 | Sub RegKeySave(i_RegKey As String, _ 31 | i_Value As String, _ 32 | Optional i_Type As String = "REG_SZ") 33 | Dim myWS As Object 34 | On Error Resume Next 35 | 36 | 'access Windows scripting 37 | Set myWS = CreateObject("WScript.Shell") 38 | 'write registry key 39 | myWS.RegWrite basekey & i_RegKey, i_Value, i_Type 40 | On Error GoTo 0 41 | End Sub 42 | 43 | 44 | 'returns True if the registry key i_RegKey was found 45 | 'and False if not 46 | Function RegKeyExists(i_RegKey As String) As Boolean 47 | Dim myWS As Object 48 | 49 | On Error GoTo ErrorHandler 50 | 'access Windows scripting 51 | Set myWS = CreateObject("WScript.Shell") 52 | 'try to read the registry key 53 | myWS.RegRead i_RegKey 54 | 'key was found 55 | RegKeyExists = True 56 | On Error GoTo 0 57 | Exit Function 58 | 59 | ErrorHandler: 60 | 'key was not found 61 | RegKeyExists = False 62 | On Error GoTo 0 63 | End Function 64 | 65 | -------------------------------------------------------------------------------- /Template_Word_2010_2013/module/ShellUtil: -------------------------------------------------------------------------------- 1 | Option Explicit 2 | Option Compare Text 3 | 4 | ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 5 | ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 6 | ' modShellAndWait 7 | ' By Chip Pearson, chip@cpearson.com, www.cpearson.com 8 | ' This page on the web site: www.cpearson.com/Excel/ShellAndWait.aspx 9 | ' 9-September-2008 10 | ' 11 | ' This module contains code for the ShellAndWait function that will Shell to a process 12 | ' and wait for that process to end before returning to the caller. 13 | 14 | ' 64 bit fix provided by Andreas Brusinsky, Gil Fuchs, Ren Vleer : Thanks. 15 | ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 16 | ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 17 | #If Win64 Or VBA7 Then 18 | Private Declare PtrSafe Function WaitForSingleObject Lib "kernel32" ( _ 19 | ByVal hHandle As LongPtr, _ 20 | ByVal dwMilliseconds As Long) As Long 21 | 22 | Private Declare PtrSafe Function OpenProcess Lib "kernel32.dll" ( _ 23 | ByVal dwDesiredAccess As Long, _ 24 | ByVal bInheritHandle As Long, _ 25 | ByVal dwProcessId As Long) As Long 26 | 27 | Private Declare PtrSafe Function CloseHandle Lib "kernel32" ( _ 28 | ByVal hObject As Long) As Long 29 | #Else 30 | Private Declare Function WaitForSingleObject Lib "kernel32" ( _ 31 | ByVal hHandle As LongPtr, _ 32 | ByVal dwMilliseconds As Long) As Long 33 | 34 | Private Declare Function OpenProcess Lib "kernel32.dll" ( _ 35 | ByVal dwDesiredAccess As Long, _ 36 | ByVal bInheritHandle As Long, _ 37 | ByVal dwProcessId As Long) As Long 38 | 39 | Private Declare Function CloseHandle Lib "kernel32" ( _ 40 | ByVal hObject As Long) As Long 41 | #End If 42 | 43 | Private Const SYNCHRONIZE = &H100000 44 | 45 | Public Enum ShellAndWaitResult 46 | Success = 0 47 | Failure = 1 48 | TimeOut = 2 49 | InvalidParameter = 3 50 | SysWaitAbandoned = 4 51 | UserWaitAbandoned = 5 52 | UserBreak = 6 53 | End Enum 54 | 55 | Public Enum ActionOnBreak 56 | IgnoreBreak = 0 57 | AbandonWait = 1 58 | PromptUser = 2 59 | End Enum 60 | 61 | Private Const STATUS_ABANDONED_WAIT_0 As Long = &H80 62 | Private Const STATUS_WAIT_0 As Long = &H0 63 | Private Const WAIT_ABANDONED As Long = (STATUS_ABANDONED_WAIT_0 + 0) 64 | Private Const WAIT_OBJECT_0 As Long = (STATUS_WAIT_0 + 0) 65 | Private Const WAIT_TIMEOUT As Long = 258& 66 | Private Const WAIT_FAILED As Long = &HFFFFFFFF 67 | Private Const WAIT_INFINITE = -1& 68 | 69 | 70 | Public Function ShellAndWait(ShellCommand As String, _ 71 | TimeOutMs As Long, _ 72 | ShellWindowState As VbAppWinStyle, _ 73 | BreakKey As ActionOnBreak) As ShellAndWaitResult 74 | ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 75 | ' ShellAndWait 76 | ' 77 | ' This function calls Shell and passes to it the command text in ShellCommand. The function 78 | ' then waits for TimeOutMs (in milliseconds) to expire. 79 | ' 80 | ' Parameters: 81 | ' ShellCommand 82 | ' is the command text to pass to the Shell function. 83 | ' 84 | ' TimeOutMs 85 | ' is the number of milliseconds to wait for the shell'd program to wait. If the 86 | ' shell'd program terminates before TimeOutMs has expired, the function returns 87 | ' ShellAndWaitResult.Success = 0. If TimeOutMs expires before the shell'd program 88 | ' terminates, the return value is ShellAndWaitResult.TimeOut = 2. 89 | ' 90 | ' ShellWindowState 91 | ' is an item in VbAppWinStyle specifying the window state for the shell'd program. 92 | ' 93 | ' BreakKey 94 | ' is an item in ActionOnBreak indicating how to handle the application's cancel key 95 | ' (Ctrl Break). If BreakKey is ActionOnBreak.AbandonWait and the user cancels, the 96 | ' wait is abandoned and the result is ShellAndWaitResult.UserWaitAbandoned = 5. 97 | ' If BreakKey is ActionOnBreak.IgnoreBreak, the cancel key is ignored. If 98 | ' BreakKey is ActionOnBreak.PromptUser, the user is given a ?Continue? message. If the 99 | ' user selects "do not continue", the function returns ShellAndWaitResult.UserBreak = 6. 100 | ' If the user selects "continue", the wait is continued. 101 | ' 102 | ' Return values: 103 | ' ShellAndWaitResult.Success = 0 104 | ' indicates the the process completed successfully. 105 | ' ShellAndWaitResult.Failure = 1 106 | ' indicates that the Wait operation failed due to a Windows error. 107 | ' ShellAndWaitResult.TimeOut = 2 108 | ' indicates that the TimeOutMs interval timed out the Wait. 109 | ' ShellAndWaitResult.InvalidParameter = 3 110 | ' indicates that an invalid value was passed to the procedure. 111 | ' ShellAndWaitResult.SysWaitAbandoned = 4 112 | ' indicates that the system abandoned the wait. 113 | ' ShellAndWaitResult.UserWaitAbandoned = 5 114 | ' indicates that the user abandoned the wait via the cancel key (Ctrl+Break). 115 | ' This happens only if BreakKey is set to ActionOnBreak.AbandonWait. 116 | ' ShellAndWaitResult.UserBreak = 6 117 | ' indicates that the user broke out of the wait after being prompted with 118 | ' a ?Continue message. This happens only if BreakKey is set to 119 | ' ActionOnBreak.PromptUser. 120 | ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 121 | 122 | Dim TaskID As Long 123 | Dim ProcHandle As Long 124 | Dim WaitRes As Long 125 | Dim Ms As Long 126 | Dim MsgRes As VbMsgBoxResult 127 | ' Dim SaveCancelKey As WdEnableCancelKey 128 | Dim ElapsedTime As Long 129 | Dim Quit As Boolean 130 | Const ERR_BREAK_KEY = 18 131 | Const DEFAULT_POLL_INTERVAL = 500 132 | 133 | If Trim(ShellCommand) = vbNullString Then 134 | ShellAndWait = ShellAndWaitResult.InvalidParameter 135 | Exit Function 136 | End If 137 | 138 | If TimeOutMs < 0 Then 139 | ShellAndWait = ShellAndWaitResult.InvalidParameter 140 | Exit Function 141 | ElseIf TimeOutMs = 0 Then 142 | Ms = WAIT_INFINITE 143 | Else 144 | Ms = TimeOutMs 145 | End If 146 | 147 | Select Case BreakKey 148 | Case AbandonWait, IgnoreBreak, PromptUser 149 | ' valid 150 | Case Else 151 | ShellAndWait = ShellAndWaitResult.InvalidParameter 152 | Exit Function 153 | End Select 154 | 155 | Select Case ShellWindowState 156 | Case vbHide, vbMaximizedFocus, vbMinimizedFocus, vbMinimizedNoFocus, vbNormalFocus, vbNormalNoFocus 157 | ' valid 158 | Case Else 159 | ShellAndWait = ShellAndWaitResult.InvalidParameter 160 | Exit Function 161 | End Select 162 | 163 | On Error Resume Next 164 | Err.Clear 165 | TaskID = Shell(ShellCommand, ShellWindowState) 166 | If (Err.Number <> 0) Or (TaskID = 0) Then 167 | ShellAndWait = ShellAndWaitResult.Failure 168 | Exit Function 169 | End If 170 | 171 | ProcHandle = OpenProcess(SYNCHRONIZE, False, TaskID) 172 | If ProcHandle = 0 Then 173 | ShellAndWait = ShellAndWaitResult.Failure 174 | Exit Function 175 | End If 176 | 177 | On Error GoTo ErrH: 178 | ' SaveCancelKey = Application.EnableCancelKey 179 | ' Application.EnableCancelKey = xlErrorHandler 180 | WaitRes = WaitForSingleObject(ProcHandle, DEFAULT_POLL_INTERVAL) 181 | Do Until WaitRes = WAIT_OBJECT_0 182 | DoEvents 183 | Select Case WaitRes 184 | Case WAIT_ABANDONED 185 | ' Windows abandoned the wait 186 | ShellAndWait = ShellAndWaitResult.SysWaitAbandoned 187 | Exit Do 188 | Case WAIT_OBJECT_0 189 | ' Successful completion 190 | ShellAndWait = ShellAndWaitResult.Success 191 | Exit Do 192 | Case WAIT_FAILED 193 | ' attach failed 194 | ShellAndWait = ShellAndWaitResult.Failure 195 | Exit Do 196 | Case WAIT_TIMEOUT 197 | ' Wait timed out. Here, this time out is on DEFAULT_POLL_INTERVAL. 198 | ' See if ElapsedTime is greater than the user specified wait 199 | ' time out. If we have exceed that, get out with a TimeOut status. 200 | ' Otherwise, reissue as wait and continue. 201 | ElapsedTime = ElapsedTime + DEFAULT_POLL_INTERVAL 202 | If Ms > 0 Then 203 | ' user specified timeout 204 | If ElapsedTime > Ms Then 205 | ShellAndWait = ShellAndWaitResult.TimeOut 206 | Exit Do 207 | Else 208 | ' user defined timeout has not expired. 209 | End If 210 | Else 211 | ' infinite wait -- do nothing 212 | End If 213 | ' reissue the Wait on ProcHandle 214 | WaitRes = WaitForSingleObject(ProcHandle, DEFAULT_POLL_INTERVAL) 215 | 216 | Case Else 217 | ' unknown result, assume failure 218 | ShellAndWait = ShellAndWaitResult.Failure 219 | Exit Do 220 | Quit = True 221 | End Select 222 | Loop 223 | 224 | CloseHandle ProcHandle 225 | ' Application.EnableCancelKey = SaveCancelKey 226 | Exit Function 227 | 228 | ErrH: 229 | 'Debug.Print "ErrH: Cancel: " & Application.EnableCancelKey 230 | If Err.Number = ERR_BREAK_KEY Then 231 | If BreakKey = ActionOnBreak.AbandonWait Then 232 | CloseHandle ProcHandle 233 | ShellAndWait = ShellAndWaitResult.UserWaitAbandoned 234 | ' Application.EnableCancelKey = SaveCancelKey 235 | Exit Function 236 | ElseIf BreakKey = ActionOnBreak.IgnoreBreak Then 237 | Err.Clear 238 | Resume 239 | ElseIf BreakKey = ActionOnBreak.PromptUser Then 240 | MsgRes = MsgBox("User Process Break." & vbCrLf & _ 241 | "Continue to wait?", vbYesNo) 242 | If MsgRes = vbNo Then 243 | CloseHandle ProcHandle 244 | ShellAndWait = ShellAndWaitResult.UserBreak 245 | ' Application.EnableCancelKey = SaveCancelKey 246 | Else 247 | Err.Clear 248 | Resume Next 249 | End If 250 | Else 251 | CloseHandle ProcHandle 252 | ' Application.EnableCancelKey = SaveCancelKey 253 | ShellAndWait = ShellAndWaitResult.Failure 254 | End If 255 | Else 256 | ' some other error. assume failure 257 | CloseHandle ProcHandle 258 | ShellAndWait = ShellAndWaitResult.Failure 259 | End If 260 | 261 | ' Application.EnableCancelKey = SaveCancelKey 262 | 263 | End Function 264 | 265 | -------------------------------------------------------------------------------- /Template_Word_2016/PlantUML_Template_v35.dotm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/plantuml/word-template/ae00c5684e9cb2e66386cdfc08cda318385d454b/Template_Word_2016/PlantUML_Template_v35.dotm -------------------------------------------------------------------------------- /Template_Word_2016/module/GDIHandling: -------------------------------------------------------------------------------- 1 | 2 | 'This module provides a LoadPictureGDI function, which can 3 | 'be used instead of VBA's LoadPicture, to load a wide variety 4 | 'of image types from disk - including png. 5 | ' 6 | 'The png format is used in Office 2007 to provide images that 7 | 'include an alpha channel for each pixel's transparency 8 | ' 9 | 'Author: Stephen Bullen 10 | 'Date: 31 October, 2006 11 | 'Email: stephen@oaltd.co.uk 12 | 13 | Option Explicit 14 | 15 | 'Declare a UDT to store a GUID for the IPicture OLE Interface 16 | Private Type GUID 17 | Data1 As Long 18 | Data2 As Integer 19 | Data3 As Integer 20 | Data4(0 To 7) As Byte 21 | End Type 22 | 23 | 'Declare a UDT to store the bitmap information 24 | Private Type PICTDESC 25 | Size As Long 26 | Type As Long 27 | hPic As Long 28 | hPal As Long 29 | End Type 30 | 31 | 'Declare a UDT to store the GDI+ Startup information 32 | Private Type GdiplusStartupInput 33 | GdiplusVersion As Long 34 | DebugEventCallback As Long 35 | SuppressBackgroundThread As Long 36 | SuppressExternalCodecs As Long 37 | End Type 38 | 39 | 'Windows API calls into the GDI+ library 40 | Private Declare PtrSafe Function GdiplusStartup Lib "GDIPlus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long 41 | Private Declare PtrSafe Function GdipCreateBitmapFromFile Lib "GDIPlus" (ByVal filename As Long, bitmap As Long) As Long 42 | Private Declare PtrSafe Function GdipCreateHBITMAPFromBitmap Lib "GDIPlus" (ByVal bitmap As Long, hbmReturn As Long, ByVal background As Long) As Long 43 | Private Declare PtrSafe Function GdipDisposeImage Lib "GDIPlus" (ByVal image As Long) As Long 44 | Private Declare PtrSafe Function GdiplusShutdown Lib "GDIPlus" (ByVal token As Long) As Long 45 | Private Declare PtrSafe Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PICTDESC, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long 46 | 47 | 48 | ' Procedure: LoadPictureGDI 49 | ' Purpose: Loads an image using GDI+ 50 | ' Returns: The image as an IPicture Object 51 | Public Function LoadPictureGDI(ByVal sFilename As String) As IPicture 52 | 53 | Dim uGdiInput As GdiplusStartupInput 54 | Dim hGdiPlus As Long 55 | Dim lResult As Long 56 | Dim hGdiImage As Long 57 | Dim hBitmap As Long 58 | 59 | 'Initialize GDI+ 60 | uGdiInput.GdiplusVersion = 1 61 | lResult = GdiplusStartup(hGdiPlus, uGdiInput) 62 | 63 | If lResult = 0 Then 64 | 65 | 'Load the image 66 | lResult = GdipCreateBitmapFromFile(StrPtr(sFilename), hGdiImage) 67 | 68 | If lResult = 0 Then 69 | 70 | 'Create a bitmap handle from the GDI image 71 | lResult = GdipCreateHBITMAPFromBitmap(hGdiImage, hBitmap, 0) 72 | 73 | 'Create the IPicture object from the bitmap handle 74 | Set LoadPictureGDI = CreateIPicture(hBitmap) 75 | 76 | 'Tidy up 77 | GdipDisposeImage hGdiImage 78 | End If 79 | 80 | 'Shutdown GDI+ 81 | GdiplusShutdown hGdiPlus 82 | End If 83 | 84 | End Function 85 | 86 | 87 | ' Procedure: CreateIPicture 88 | ' Purpose: Converts a image handle into an IPicture object. 89 | ' Returns: The IPicture object 90 | Private Function CreateIPicture(ByVal hPic As Long) As IPicture 91 | 92 | Dim lResult As Long, uPicInfo As PICTDESC, IID_IDispatch As GUID, IPic As IPicture 93 | 94 | 'OLE Picture types 95 | Const PICTYPE_BITMAP = 1 96 | 97 | ' Create the Interface GUID (for the IPicture interface) 98 | With IID_IDispatch 99 | .Data1 = &H7BF80980 100 | .Data2 = &HBF32 101 | .Data3 = &H101A 102 | .Data4(0) = &H8B 103 | .Data4(1) = &HBB 104 | .Data4(2) = &H0 105 | .Data4(3) = &HAA 106 | .Data4(4) = &H0 107 | .Data4(5) = &H30 108 | .Data4(6) = &HC 109 | .Data4(7) = &HAB 110 | End With 111 | 112 | ' Fill uPicInfo with necessary parts. 113 | With uPicInfo 114 | .Size = Len(uPicInfo) 115 | .Type = PICTYPE_BITMAP 116 | .hPic = hPic 117 | .hPal = 0 118 | End With 119 | 120 | ' Create the Picture object. 121 | lResult = OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, IPic) 122 | 123 | ' Return the new Picture object. 124 | Set CreateIPicture = IPic 125 | 126 | End Function 127 | 128 | 129 | -------------------------------------------------------------------------------- /Template_Word_2016/module/PlantUML: -------------------------------------------------------------------------------- 1 | ' ======================================================================== 2 | ' Plantuml : a free UML diagram generator 3 | ' ======================================================================== 4 | ' 5 | ' (C) Copyright 2009-2017, Arnaud Roques 6 | ' 7 | ' Project Info: http://plantuml.com 8 | ' 9 | ' If you like this project or if you find it useful, you can support us at: 10 | ' 11 | ' http://plantuml.com/patreon (only 1$ per month!) 12 | ' http://plantuml.com/paypal 13 | ' 14 | ' This file is part of PlantUML. 15 | ' 16 | ' Plantuml is free software; you can redistribute it and/or modify it 17 | ' under the terms of the GNU General Public License as published by 18 | ' the Free Software Foundation, either version 3 of the License, or 19 | ' (at your option) any later version. 20 | ' 21 | ' Plantuml distributed in the hope that it will be useful, but 22 | ' WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY 23 | ' or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public 24 | ' License for more details. 25 | ' 26 | ' You should have received a copy of the GNU General Public 27 | ' License along with this library; if not, write to the Free Software 28 | ' Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, 29 | ' USA. 30 | ' 31 | ' [Java is a trademark or registered trademark of Sun Microsystems, Inc. 32 | ' in the United States and other countries.] 33 | ' 34 | ' Original Author: Arnaud Roques 35 | ' Word Macro: Alain Bertucat / Matthieu Sabatier 36 | ' Improved error management : Christopher Fuhrman 37 | ' http://vbadud.blogspot.fr/2008/12/how-to-set-and-reset-track-changes.html 38 | ' Version 008 39 | ' changes by Adriaan van den Brand & Pieter Smith 40 | ' - direct writing of files (instead of creating documents and using paste & save) 41 | ' - fixed bug in 006/007 version which inserted wrong images (because the javalock didn't work 42 | ' use ShellUtil which waits until completion of java 43 | ' - integrated in word template for easy integration in word environment 44 | ' version 010 (template 2.6) 45 | ' changes by Adriaan van den Brand 46 | ' - use of utf-8 for plantuml files 47 | ' - add @rescale for post processing scale 48 | ' - fix language dependency in styles 49 | ' - add autoformat on/off functions' 50 | ' - remove add-in toolbar (obsolete by plantuml toolbar) (toolbar and statusbutton code commented out) 51 | ' Open issue: onload doesn't work yet (intended for feedback via ribbon) 52 | ' Version 011 53 | ' changes by Adriaan van den Brand 54 | ' add preferences 55 | ' add png/eps selector (default remains eps) 56 | ' Version 012 57 | ' Add include path: document path (thanks Matt) 58 | ' Version 013 59 | ' copy/paste compatibility (now style is toggled from hidden/visible instead of display hidden text 60 | ' auto scale (reduce) to fit page 61 | ' 62 | ' version 014 63 | ' 64 bit compatibility added (provided by Andreas Brusinsky, Gil Fuchs, Ren Vleer) 64 | ' version 015 65 | ' added ftp 66 | ' version 032 67 | ' see http://plantuml.sourceforge.net/qa/?qa=4083/plantuml_template_v30-does-not-work 68 | ' see http://plantuml.sourceforge.net/qa/?qa=3329/word-2010-runtime-error-when-generating-new-plantuml-image 69 | ' replace ActiveDocument.PageSetup with currentparagraph.PageSetup to solve sections issues 70 | 'version 033 71 | ' updated PtrSafe functions for Word 2016 Support 72 | 'version 034 73 | ' updated Vector Option to be of SVG format, which is actually supported by Word 2016+ 74 | 75 | #If Win64 Or VBA7 Then 76 | Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 77 | #Else 78 | Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 79 | #End If 80 | 81 | 82 | Const startuml = "@start" 83 | Const enduml = "@end" 84 | 85 | Dim vectorgraphics As Boolean 86 | Dim useFTP As Boolean 87 | Dim FTPURL As String 88 | 89 | 90 | Function get_gfx_extension() As String 91 | If vectorgraphics Then 92 | 'IMF-20190205: eps are not safe anymore, Word doesn't like it... 93 | 'get_gfx_extension = "*.eps" 94 | get_gfx_extension = "*.svg" 95 | Else 96 | get_gfx_extension = "*.png" 97 | End If 98 | End Function 99 | 100 | 101 | Function get_plantuml_options() As String 102 | Dim options As String 103 | options = "" 104 | If vectorgraphics Then 105 | 'IMF-20190205: eps are not safe anymore, Word doesn't like it... 106 | 'options = options + " -teps" 107 | options = options + " -tsvg" 108 | End If 109 | 110 | get_plantuml_options = options 111 | End Function 112 | 113 | Function getExePath(searchfor As String, ByRef try As String) As String 114 | Dim fullFilePath As String 115 | Set fs = CreateObject("Scripting.FileSystemObject") 116 | 117 | nbTemplates = ActiveDocument.Parent.Templates.Count 118 | fullFilePath = GetLocalPath(ActiveDocument.FullName) 119 | mainPath = Left(fullFilePath, InStrRev(fullFilePath, "\") - 1) 120 | try = mainPath & "\" 121 | 122 | nb = InStrRev(mainPath, "\") 123 | Do While nb > 1 And fs.FileExists(mainPath + searchfor) = False 124 | mainPath = Left(mainPath, nb - 1) 125 | try = try & vbCrLf & mainPath & "\" 126 | nb = InStrRev(mainPath, "\") 127 | Loop 128 | 129 | ' see http://plantuml.sourceforge.net/qa/?qa=4083/plantuml_template_v30-does-not-work 130 | ' In case mainPath is the empty string as the active document is the empty string, 131 | ' and in case the plantuml.jar can be found in the current directory, the below 132 | ' code results in mainPath being the empty string which would work properly if 133 | ' the calling method would not check for an empty string as execution path 134 | ' and state this is wrong and has to fail. Therefore, change main path in case 135 | ' it is an empty string at this point with an explicit, not empty string stating to 136 | ' use the current folder as relative path. 137 | If mainPath = "" Then 138 | mainPath = ".\" 139 | End If 140 | 141 | For i = 1 To nbTemplates 142 | If fs.FileExists(mainPath + searchfor) = False Then 143 | mainPath = ActiveDocument.Parent.Templates.Item(i).Path 144 | try = try & vbCrLf & ActiveDocument.Parent.Templates.Item(i).Path & "\" 145 | nb = InStrRev(mainPath, "\") 146 | Do While nb > 1 And fs.FileExists(mainPath + searchfor) = False 147 | mainPath = Left(mainPath, nb - 1) 148 | try = try & vbCrLf & mainPath & "\" 149 | nb = InStrRev(mainPath, "\") 150 | Loop 151 | End If 152 | Next i 153 | 154 | If fs.FileExists(mainPath + searchfor) Then 155 | getExePath = mainPath 156 | Else 157 | getExePath = "Error : Cannot find plantuml.jar in :" & vbCrLf & try 158 | End If 159 | 160 | 161 | End Function 162 | 163 | ' ========================================================= 164 | ' This function returns the path for plantuml.jar 165 | Function getJarPath() As String 166 | Set fs = CreateObject("Scripting.FileSystemObject") 167 | Dim trypath As String 168 | trypath = "" 169 | jarPath = getExePath("\plantuml.jar", trypath) 170 | If (jarPath <> "") And fs.FileExists(jarPath + "\plantuml.jar") Then 171 | getJarPath = jarPath 172 | Else 173 | getJarPath = "Error : Cannot find plantuml.jar in :" & vbCrLf & trypath 174 | End If 175 | 176 | End Function 177 | 178 | 179 | 180 | ' ========================================================= 181 | ' This function returns the path for plantuml.jar 182 | Function getDotPath() As String 183 | Set fs = CreateObject("Scripting.FileSystemObject") 184 | Dim trypath As String 185 | Dim searchfor As String 186 | trypath = Environ("%APPDATA%") 187 | If Environ("GRAPHVIZ_DOT") <> "" Then Exit Function 188 | searchfor = "\release\bin\dot.exe" 189 | dotPath = getExePath(searchfor, trypath) 190 | If (dotPath <> "") And fs.FileExists(dotPath + searchfor) Then 191 | getDotPath = dotPath + searchfor 192 | Else 193 | getDotPath = "" '"Error : Cannot find graphviz in :" & vbCrLf & trypath 194 | End If 195 | End Function 196 | 197 | 198 | ' ========================================================= 199 | ' Print out the used plantuml.jar 200 | Sub ShowPlantumlJarPath() 201 | Set fs = CreateObject("Scripting.FileSystemObject") 202 | jarPath = getJarPath() 203 | If jarPath <> "" And fs.FileExists(jarPath) Then 204 | MsgBox "OK : " & jarPath 205 | Else 206 | MsgBox jarPath 207 | End If 208 | End Sub 209 | ' ========================================================= 210 | ' Used to migrate from previous PlantUML macro version 211 | Sub RemoveOldVersionPlantUMLSyles() 212 | On Error GoTo DeleteEnd 213 | ActiveDocument.Styles("PlantUML").Delete 214 | On Error GoTo 0 215 | DeleteEnd: 216 | On Error GoTo 0 217 | Call Macro_UML_all 218 | 219 | End Sub 220 | ' ========================================================= 221 | ' Called when the user click on "UML.*" 222 | Sub Macro_UML_all() 223 | Macro_UML ("all") 224 | End Sub 225 | 226 | ' ========================================================= 227 | Sub Macro_UML_styles() 228 | CreateStyle (True) 229 | End Sub 230 | 231 | ' ========================================================= 232 | ' Called when the user click on "UML.1" 233 | Function Macro_UML_parg() 234 | Macro_UML ("parg") 235 | End Function 236 | 237 | ' ========================================================= 238 | Function WriteToFile(sFile, sText As String) 239 | Dim objStream As Object 240 | Set objStream = CreateObject("ADODB.Stream") 241 | With objStream 242 | .Type = 2 ' Stream type = text / string data 243 | .Mode = 3 244 | '.Charset = "ascii" ' plantUML can only deal with ASCII: Setting to ASCII kills Word's autoformatting 245 | .Charset = "utf-8" ' plantUML can only deal with ASCII: Setting to ASCII kills Word's autoformatting 246 | .Open 247 | .WriteText sText 248 | .SaveToFile sFile, 2 249 | End With 250 | End Function 251 | 252 | Function Macro_UML(scope) As String 253 | ' Generate diagrams image from a PlantUML source textual description in the Word Document 254 | ' Scope can be "parg" or "all" 255 | ' 256 | ' - Initialisations 257 | Dim currentIndex As Long 258 | Dim ftphandle As Long 259 | Dim JavaCommand As String 260 | Dim GraphVizOption As String 261 | GraphVizOption = "" 262 | Dim scalefiles As Scripting.Dictionary 263 | Set scalefiles = New Scripting.Dictionary 264 | ToolbarInit 265 | ' Set statusButton = CommandBars("UML").Controls(6) 266 | If RegKeyRead("VectorGraphics") = "ON" Then 267 | vectorgraphics = True 268 | End If 269 | If RegKeyRead("FTPMode") = "ON" Then 270 | useFTP = True 271 | End If 272 | 273 | FTPURL = RegKeyRead("FTPURL", "127.0.0.1:4242") 274 | 275 | 276 | Call CreateStyle(True) 277 | Call CreateStyleImg 278 | Call ShowPlantuml 279 | 280 | Call ShowHiddenText 281 | Selection.Range.Select 282 | ' 283 | ' documentId is the filename with its path, without extension 284 | ' 285 | documentId = ActiveDocument.Name 286 | documentId = Left(documentId, Len(documentId) - 4) 287 | 288 | ' Check for the presente of plantuml.jar 289 | 290 | Set fs = CreateObject("Scripting.FileSystemObject") 291 | jarPath = getJarPath() 292 | If (jarPath = "") Or fs.FileExists(jarPath + "\plantuml.jar") = False Then 293 | MsgBox jarPath 294 | GoTo Macro_UML_exit 295 | End If 296 | dotPath = getDotPath() 297 | If dotPath <> "" Then 298 | GraphVizOption = " -graphvizdot """ & dotPath & """" 299 | End If 300 | 301 | ' - Phase 1 302 | ' We create a file text per bloc of diagrams 303 | ' We look for @startuml 304 | ' We open the textfile in background (visible:=false) 305 | ' We add to the name a number on 4 digit 306 | ' The text bloc is put on "PlantUML" style 307 | ' Then the bloc is copied into the text file 308 | 309 | ' statusButton.Caption = "Extract" 310 | ' statusButton.Visible = False 311 | ' statusButton.Visible = True 312 | If scope = "all" Then 313 | Set parsedtext = ActiveDocument.Content 314 | isForward = True 315 | Else 316 | Set parsedtext = Selection.Range 317 | ' parsedtext.Collapse 318 | isForward = False 319 | End If 320 | 321 | parsedtext.Find.Execute FindText:=startuml, Forward:=isForward 322 | If parsedtext.Find.Found = True Then 323 | 'We keep the the first line only "@startuml" with the carriage return 324 | Set singleparagraph = parsedtext.Paragraphs(1).Range 325 | singleparagraph.Collapse 326 | Else 327 | GoTo Macro_UML_exit 328 | End If 329 | Application.ScreenUpdating = False 330 | jobDone = False 331 | If useFTP Then 332 | ftphandle = ftpOpen(FTPURL) 333 | If ftphandle <= 0 Then 334 | MsgBox "Cannot create ftp connection, aborting" 335 | Exit Function 336 | End If 337 | End If 338 | 339 | Do While parsedtext.Find.Found = True And _ 340 | (scope = "all" Or currentIndex < 1) And Not jobDone 341 | ' statusButton.Caption = "Extract." & currentIndex + 1 342 | ' statusButton.Visible = False 343 | ' statusButton.Visible = True 344 | Set currentparagraph = parsedtext.Paragraphs(1) 345 | Set paragraphRange = currentparagraph.Range 346 | paragraphRange.Collapse 347 | jobDone = False 348 | Do Until jobDone 349 | If Left(currentparagraph.Range.Text, Len(startuml)) = startuml Then 350 | Set paragraphRange = currentparagraph.Range 351 | paragraphRange.Collapse 352 | 353 | End If 354 | paragraphRange.MoveEnd Unit:=wdParagraph 355 | If Left(currentparagraph.Range.Text, Len(enduml)) = enduml Then 356 | Dim s As String 357 | paragraphRange.Style = "PlantUML" 358 | s = paragraphRange.Text 359 | currentIndex = currentIndex + 1 360 | 361 | factor = 0# 362 | On Error Resume Next 363 | p = InStr(LCase(s), "@rescale ") 364 | If p > 0 Then 365 | 366 | endscale = InStr(p + 9, s, Chr(13)) - p - 9 367 | factorstr = Mid(s, p + 9, endscale) 368 | factor = Val(factorstr) 369 | End If 370 | On Error GoTo 0 371 | 372 | textFileId = documentId & "_extr" & Right("000" & currentIndex, 4) & ".txt" 373 | If factor > 0 Then 374 | scalefiles(Replace(textFileId, ".txt", "")) = factor 375 | End If 376 | If scope = "fetch" Then 377 | Macro_UML = Mid(s, 1, Len(s) - 1) 378 | Application.ScreenUpdating = True 379 | Exit Function 380 | End If 381 | fileName = jarPath & "\" & textFileId 382 | 383 | WriteToFile fileName, Mid(s, 1, Len(s) - 1) 384 | If useFTP Then 385 | retValue = FtpStor(ftphandle, jarPath & "\" & textFileId, textFileId) 386 | End If 387 | 388 | If scope <> "all" Then 389 | jobDone = True 390 | End If 391 | 392 | End If 393 | Set currentparagraph = currentparagraph.Next 394 | If currentparagraph Is Nothing Then 395 | jobDone = True 396 | End If 397 | Loop 398 | parsedtext.Collapse Direction:=wdCollapseEnd 399 | If scope = "all" Then 400 | parsedtext.Find.Execute FindText:=startuml, Forward:=True 401 | End If 402 | Loop 403 | Application.ScreenUpdating = True 404 | ' 405 | ' We create a lock file that will be deleted by the Java program to indicate the end of Java process 406 | ' 407 | ' statusButton.Caption = "Gener" 408 | ' statusButton.Visible = False 409 | ' statusButton.Visible = True 410 | 411 | ' 412 | ' Call to PlantUML to generate images from text descriptions 413 | ' 414 | ' version 012 : add include path to document path 415 | ' if document is loaded from disk (by drive letter) 416 | If useFTP Then 417 | For i = 1 To currentIndex 418 | imageId = documentId & "_extr" & Right("000" & i, 4) & ".png" 419 | imageName = jarPath & "\" & imageId 420 | retValue = FtpRetr(ftphandle, imageName, imageId) 421 | Next i 422 | 'Sleep 200 423 | Else 424 | Set lockFile = Documents.Add(Visible:=False) 425 | lockFile.SaveAs fileName:=jarPath & "\javaumllock.tmp", FileFormat:=wdFormatText 426 | lockFile.Close 427 | 428 | Dim fullFilePath As String 429 | Dim mainPath As String 430 | fullFilePath = GetLocalPath(ActiveDocument.FullName) 431 | mainPath = Left(fullFilePath, InStrRev(fullFilePath, "\") - 1) 432 | 433 | Dim javaoptions 434 | javaoptions = " -Dplantuml.include.path=" & Chr(34) & mainPath & Chr(34) & " " 435 | 436 | JavaCommand = "java " & javaoptions _ 437 | & "-classpath """ & jarPath & "\plantuml.jar;" & _ 438 | jarPath & "\plantumlskins.jar"" net.sourceforge.plantuml.Run -word """ & jarPath & "/""" & GraphVizOption & get_plantuml_options() 439 | 440 | 441 | 442 | 443 | result = ShellAndWait(JavaCommand, 0, vbMinimizedFocus, AbandonWait) 444 | If result <> Success Then 445 | MsgBox "Java command execution failed (break key?)" 446 | Return 447 | End If 448 | 449 | 450 | ' This sleep is needed, but we don't know why... 451 | Sleep 1000 452 | End If 453 | ' 454 | ' Phase 2 : 455 | ' Insertion of images into the word document 456 | ' We insert the image after the textual block that describe the diagram 457 | ' 458 | jobDone = False 459 | nrOfImages = currentIndex 460 | currentIndex = 0 461 | 'Sleep 50 * nrOfImages 462 | 463 | ' We wait for the file javaumllock.tmp to be deleted by Java 464 | ' which means that the process is ended 465 | ' 466 | ' get images via ftp or wait for java to end 467 | If useFTP Then 468 | 469 | Else 470 | Do 471 | currentIndex = currentIndex + 1 472 | ' statusButton.Caption = "Gener." & currentIndex 473 | ' statusButton.Visible = False 474 | ' statusButton.Visible = True 475 | 476 | DoEvents 477 | 478 | Sleep 100 ' Sleep 500 479 | If fs.FileExists(jarPath & "\javaumllock.tmp") = False Then 480 | jobDone = True 481 | Exit Do 482 | End If 483 | If currentIndex > 30 Then 484 | ' statusButton.Visible = False 485 | MsgBox ("Java Timeout. Aborted.") 486 | Exit Do 487 | End If 488 | Loop 489 | 490 | If jobDone = False Then 491 | End 492 | End If 493 | End If 494 | 495 | ' statusButton.Caption = "Inser." 496 | ' statusButton.Visible = False 497 | ' statusButton.Visible = True 498 | 499 | If scope = "all" Then 500 | Set parsedtext = ActiveDocument.Content 501 | isForward = True 502 | Else 503 | Set parsedtext = singleparagraph 504 | isForward = True 505 | End If 506 | parsedtext.Find.Execute FindText:=enduml, Forward:=isForward 507 | currentIndex = 0 508 | bTrackRevFlag = ActiveDocument.TrackRevisions 509 | ActiveDocument.TrackRevisions = False 510 | Do While parsedtext.Find.Found = True And (scope = "all" Or currentIndex < 1) 511 | currentIndex = currentIndex + 1 512 | ' statusButton.Caption = "Inser." & currentIndex 513 | ' statusButton.Visible = False 514 | ' statusButton.Visible = True 515 | On Error GoTo LastParagraph 516 | 517 | 'error handler will assume that the @enduml is at the last paragraph of the document. Not always true 518 | 519 | Set currentparagraph = parsedtext.Paragraphs(1).Next.Range 520 | Do While currentparagraph.InlineShapes.Count > 0 And currentparagraph.Style = "PlantUMLImg" 521 | currentparagraph.Delete 522 | Set currentparagraph = parsedtext.Paragraphs(1).Next.Range 523 | Loop 524 | On Error GoTo 0 525 | Set currentRange = currentparagraph 526 | imagesDirectory = jarPath & "\" & documentId & "_extr" & Right("000" & currentIndex, 4) & get_gfx_extension() 527 | image = Dir(imagesDirectory) 528 | While image <> "" 529 | ' Contain the text of the error 530 | errorTextFile = jarPath & "\" & Left(image, Len(image) - 4) & ".err" 531 | BaseName = Left(image, Len(image) - 4) 532 | Set currentparagraph = ActiveDocument.Paragraphs.Add(Range:=currentRange).Range 533 | Set currentRange = currentparagraph.Paragraphs(1).Next.Range 534 | currentparagraph.Style = "PlantUMLImg" 535 | currentparagraph.Collapse 536 | 537 | Set image = currentparagraph.InlineShapes.AddPicture _ 538 | (fileName:=jarPath & "\" & image _ 539 | , LinkToFile:=False, SaveWithDocument:=True) 540 | 541 | ' check if scale was forced in plantuml code 542 | If scalefiles(CStr(BaseName)) > 0.1 And scalefiles(CStr(BaseName)) < 5 Then 543 | image.ScaleWidth = scalefiles(CStr(BaseName)) * 100 544 | image.ScaleHeight = scalefiles(CStr(BaseName)) * 100 545 | Else 546 | ' new 2.9 547 | ' default: autoscale; reduce to fit if > margin. 100% if picture fits 548 | With image 549 | .LockAspectRatio = msoFalse 550 | .ScaleWidth = 100 551 | .ScaleHeight = 100 552 | percentW = currentparagraph.PageSetup.TextColumns.Width / image.Width 553 | percentH = (currentparagraph.PageSetup.PageHeight - currentparagraph.PageSetup.TopMargin - currentparagraph.PageSetup.BottomMargin) / image.Height 554 | If percentH < percentW Then percentW = percentH 555 | If percentW < 1 Then 556 | .ScaleWidth = percentW * 100 557 | .ScaleHeight = percentW * 100 558 | End If 559 | End With 560 | End If 561 | 562 | If fs.FileExists(errorTextFile) Then 563 | image.AlternativeText = LoadTextFile(errorTextFile) 564 | Beep 565 | Else 566 | image.AlternativeText = "Generated by PlantUML" 567 | End If 568 | 569 | If image.ScaleHeight > 100 Or image.ScaleWidth > 100 Then 570 | image.Reset 571 | End If 572 | image = Dir() 573 | Wend 574 | parsedtext.Collapse Direction:=wdCollapseEnd 575 | parsedtext.Find.Execute FindText:=enduml, Forward:=True 576 | Loop 577 | ActiveDocument.TrackRevisions = bTrackRevFlag 578 | 579 | ' 580 | ' Phase 3 : suppression of temporary files (text and PNG) 581 | ' 582 | Phase3: 583 | ' statusButton.Caption = "Delete" 584 | ' statusButton.Visible = False 585 | ' statusButton.Visible = True 586 | If Not useFTP Then 587 | On Error Resume Next 588 | 589 | Kill (jarPath & "\" & documentId & "_extr*.*") 590 | On Error GoTo 0 591 | Else 592 | ftpClose ftphandle 593 | End If 594 | Macro_UML_exit: 595 | 596 | ' statusButton.Visible = False 597 | 598 | 'We show the hidden description text 599 | Call ShowHiddenText 600 | DoubleCheckStyle 601 | Exit Function 602 | 603 | 604 | ' This is need when the very last line of the Word document (or table cell) is @enduml 605 | LastParagraph: 606 | Selection.EndKey Unit:=wdStory 607 | Selection.TypeParagraph 608 | Selection.ClearFormatting 609 | 610 | imagesDirectory = jarPath & "\" & documentId & "_extr" & Right("000" & currentIndex, 4) & get_gfx_extension 611 | image = Dir(imagesDirectory) 612 | While image <> "" 613 | ' Contain the text of the error 614 | errorTextFile = jarPath & "\" & Left(image, Len(image) - 4) & ".err" 615 | 616 | Set currentparagraph = ActiveDocument.Paragraphs.Add.Range 617 | Set currentRange = currentparagraph.Paragraphs(1).Next.Range 618 | currentparagraph.Style = "PlantUMLImg" 619 | currentparagraph.Collapse 620 | 621 | Set image = currentparagraph.InlineShapes.AddPicture _ 622 | (fileName:=jarPath & "\" & image _ 623 | , LinkToFile:=False, SaveWithDocument:=True) 624 | 625 | If fs.FileExists(errorTextFile) Then 626 | image.AlternativeText = LoadTextFile(errorTextFile) 627 | Beep 628 | Else 629 | image.AlternativeText = "Generated by PlantUML" 630 | End If 631 | 632 | If image.ScaleHeight > 100 Or image.ScaleWidth > 100 Then 633 | image.Reset 634 | End If 635 | image = Dir() 636 | Wend 637 | 638 | 'Resume Next 639 | GoTo Phase3 640 | 641 | End Function 642 | 643 | ' ========================================================= 644 | ' Initialize the plantuml ToolBar 645 | Sub ToolbarInit() 646 | On Error Resume Next 647 | ActiveDocument.CommandBars("UML").Delete 648 | On Error GoTo 0 649 | End Sub 650 | 651 | 'doesn't work yet? 652 | 'Callback for customUI.onLoad 653 | Sub RibbonOnLoad(ribbon As IRibbonUI) 654 | End Sub 655 | 656 | 657 | 'original toolbar of plantuml, now obsolete 658 | Function OldToolbarInit() 659 | On Error GoTo ToolbarCreation 660 | Set toolBar = ActiveDocument.CommandBars("UML") 661 | On Error GoTo 0 662 | 663 | toolBar.Visible = True 664 | 665 | On Error GoTo ButtonAdd 666 | Set currentButton = toolBar.Controls(1) 667 | On Error GoTo 0 668 | currentButton.OnAction = "PlantUML.SwitchP" 669 | currentButton.Style = msoButtonCaption 670 | currentButton.Caption = Chr(182) 671 | currentButton.Visible = True 672 | 673 | On Error GoTo ButtonAdd 674 | Set currentButton = toolBar.Controls(2) 675 | On Error GoTo 0 676 | currentButton.OnAction = "PlantUML.ShowPlantuml" 677 | currentButton.Style = msoButtonCaption 678 | currentButton.Caption = "Show PlantUML" 679 | currentButton.Visible = True 680 | 681 | On Error GoTo ButtonAdd 682 | Set currentButton = toolBar.Controls(3) 683 | On Error GoTo 0 684 | currentButton.OnAction = "PlantUML.HidePlantuml" 685 | currentButton.Style = msoButtonCaption 686 | currentButton.Caption = "Hide PlantUML" 687 | currentButton.Visible = True 688 | 689 | On Error GoTo ButtonAdd 690 | Set currentButton = toolBar.Controls(4) 691 | On Error GoTo 0 692 | currentButton.OnAction = "PlantUML.Macro_UML_all" 693 | currentButton.Style = msoButtonCaption 694 | currentButton.Caption = "UML.*" 695 | currentButton.Visible = True 696 | 697 | On Error GoTo ButtonAdd 698 | Set currentButton = toolBar.Controls(5) 699 | On Error GoTo 0 700 | currentButton.OnAction = "PlantUML.Macro_UML_parg" 701 | currentButton.Style = msoButtonCaption 702 | currentButton.Caption = "UML.1" 703 | currentButton.Visible = True 704 | 705 | On Error GoTo ButtonAdd 706 | Set currentButton = toolBar.Controls(6) 707 | On Error GoTo 0 708 | currentButton.OnAction = "" 709 | currentButton.Style = msoButtonCaption 710 | currentButton.Caption = "Trace" 711 | currentButton.Visible = True 712 | Exit Function 713 | 714 | ToolbarCreation: 715 | Set toolBar = ActiveDocument.CommandBars.Add(Name:="UML") 716 | Resume Next 717 | 718 | ButtonAdd: 719 | Set currentButton = toolBar.Controls.Add(Type:=msoControlButton, Before:=toolBar.Controls.Count + 1) 720 | Resume Next 721 | 722 | End Function 723 | 724 | ' ========================================================= 725 | ' We need to double check that the style is present in the document 726 | Function DoubleCheckStyle() 727 | CreateStyle 728 | CreateStyleImg 729 | Set mystyle = ActiveDocument.Styles("PlantUML") 730 | 'myStyle.BaseStyle = ActiveDocument.Styles("Normal") 731 | 'above line fixed to work on international versions of Word 732 | mystyle.BaseStyle = ActiveDocument.Styles(WdBuiltinStyle.wdStyleNormal) 733 | 734 | mystyle.AutomaticallyUpdate = True 735 | With mystyle.Font 736 | .Name = "Courier New" 737 | .size = 9 738 | .Hidden = False 739 | '.Hidden = True ' change in plantuml template 2.9 to allow copy/paste 740 | .Color = wdColorGreen 741 | End With 742 | End Function 743 | 744 | 745 | ' ========================================================= 746 | Function CreateStyle(Optional overwriteIfStyleExists As Boolean = False) 747 | On Error GoTo CreateStyleAdding 748 | Set mystyle = ActiveDocument.Styles("PlantUML") 749 | If overwriteIfStyleExists = True Then 750 | GoTo CreateStyleOverwrite 751 | End If 752 | Exit Function 753 | CreateStyleAdding: 754 | Set mystyle = ActiveDocument.Styles.Add(Name:="PlantUML", Type:=wdStyleTypeParagraph) 755 | CreateStyleOverwrite: 756 | 'myStyle.BaseStyle = ActiveDocument.Styles("Normal") 757 | ' fix for international versions of Word 758 | mystyle.BaseStyle = ActiveDocument.Styles(WdBuiltinStyle.wdStyleNormal) 759 | mystyle.AutomaticallyUpdate = True 760 | With mystyle.Font 761 | .Name = "Courier New" 762 | .size = 9 763 | .Hidden = False 764 | .Hidden = True 765 | .Color = wdColorGreen 766 | End With 767 | 768 | mystyle.NoProofing = True 769 | With mystyle.ParagraphFormat 770 | With .Shading 771 | .Texture = wdTextureNone 772 | .ForegroundPatternColor = wdColorAutomatic 773 | .BackgroundPatternColor = wdColorLightGreen 774 | End With 775 | .LineSpacingRule = wdLineSpaceSingle 776 | 'new style: single line, left aligned 777 | .SpaceBefore = 0 778 | .SpaceBeforeAuto = False 779 | .SpaceAfter = 0 780 | .SpaceAfterAuto = False 781 | .LineSpacingRule = wdLineSpaceSingle 782 | .Alignment = wdAlignParagraphLeft 783 | .LineUnitBefore = 0 784 | .LineUnitAfter = 0 785 | .LeftIndent = CentimetersToPoints(0) 786 | 787 | With .Shading 788 | .Texture = wdTextureNone 789 | .ForegroundPatternColor = wdColorAutomatic 790 | .BackgroundPatternColor = 12254650 791 | 792 | End With 793 | With .Borders(wdBorderLeft) 794 | .LineStyle = wdLineStyleDashLargeGap 795 | .LineWidth = wdLineWidth050pt 796 | .Color = 3910491 797 | End With 798 | With .Borders(wdBorderRight) 799 | .LineStyle = wdLineStyleDashLargeGap 800 | .LineWidth = wdLineWidth050pt 801 | .Color = 3910491 802 | End With 803 | With .Borders(wdBorderTop) 804 | .LineStyle = wdLineStyleDashLargeGap 805 | .LineWidth = wdLineWidth050pt 806 | .Color = 3910491 807 | End With 808 | With .Borders(wdBorderBottom) 809 | .LineStyle = wdLineStyleDashLargeGap 810 | .LineWidth = wdLineWidth050pt 811 | .Color = 3910491 812 | End With 813 | With .Borders 814 | .DistanceFromTop = 1 815 | .DistanceFromLeft = 4 816 | .DistanceFromBottom = 1 817 | .DistanceFromRight = 4 818 | .Shadow = False 819 | End With 820 | End With 'paragraphformat 821 | 822 | ' ajout des tabulations 823 | mystyle.NoSpaceBetweenParagraphsOfSameStyle = False 824 | mystyle.ParagraphFormat.TabStops.ClearAll 825 | mystyle.ParagraphFormat.TabStops.Add Position:= _ 826 | CentimetersToPoints(1), Alignment:=wdAlignTabLeft, Leader:=wdTabLeaderSpaces 827 | mystyle.ParagraphFormat.TabStops.Add Position:= _ 828 | CentimetersToPoints(2), Alignment:=wdAlignTabLeft, Leader:=wdTabLeaderSpaces 829 | mystyle.ParagraphFormat.TabStops.Add Position:= _ 830 | CentimetersToPoints(3), Alignment:=wdAlignTabLeft, Leader:=wdTabLeaderSpaces 831 | mystyle.ParagraphFormat.TabStops.Add Position:= _ 832 | CentimetersToPoints(4), Alignment:=wdAlignTabLeft, Leader:=wdTabLeaderSpaces 833 | 834 | 835 | End Function 836 | 837 | ' ========================================================= 838 | Function CreateStyleImg() 839 | 840 | On Error GoTo CreateStyleImgAdding 841 | Set mystyle = ActiveDocument.Styles("PlantUMLImg") 842 | mystyle.Font.Hidden = False 843 | On Error GoTo CreateStyleSkip 844 | mystyle.BaseStyle = ActiveDocument.Styles("Normal") 845 | CreateStyleSkip: 846 | On Error GoTo 0 847 | Exit Function 848 | CreateStyleImgAdding: 849 | Set mystyle = ActiveDocument.Styles.Add(Name:="PlantUMLImg", Type:=wdStyleTypeParagraph) 850 | mystyle.AutomaticallyUpdate = True 851 | End Function 852 | 853 | ' ========================================================= 854 | ' We show the hidden text 855 | Function ShowPlantuml() 856 | DoubleCheckStyle 857 | 858 | 'WordBasic.ShowComments 859 | ' We put a bookmark to retrieve position after showing the text 860 | ActiveDocument.Bookmarks.Add Name:="Position", Range:=Selection.Range 861 | 862 | Set mystyle = ActiveDocument.Styles("PlantUML") 863 | ' Set toolBar = ActiveDocument.CommandBars("UML") 864 | 865 | ' toolBar.Controls(2).Visible = False 866 | ' toolBar.Controls(3).Visible = True 867 | ' toolBar.Controls(4).Visible = True 868 | ' toolBar.Controls(5).Visible = True 869 | 870 | Call ShowHiddenText 871 | 872 | 'We go back to the bookmark and we delete it 873 | Selection.GoTo What:=wdGoToBookmark, Name:="Position" 874 | ActiveDocument.Bookmarks(Index:="Position").Delete 875 | 876 | End Function 877 | 878 | 879 | ' ========================================================= 880 | ' MSR - management of display/hide text with style "PlantUML" 881 | Function HidePlantuml() 882 | DoubleCheckStyle 883 | 'WordBasic.ShowComments 884 | ' We put a bookmark to retrieve position after showing the text 885 | ActiveDocument.Bookmarks.Add Name:="Position", Range:=Selection.Range 886 | 887 | Set mystyle = ActiveDocument.Styles("PlantUML") 888 | ' Set toolBar = ActiveDocument.CommandBars("UML") 889 | 890 | ' toolBar.Controls(2).Visible = True 891 | ' toolBar.Controls(3).Visible = False 892 | ' toolBar.Controls(4).Visible = False 893 | ' toolBar.Controls(5).Visible = False 894 | 895 | Call HideHiddenText 896 | 897 | 'We go back to the bookmark and we delete it 898 | Selection.GoTo What:=wdGoToBookmark, Name:="Position" 899 | ActiveDocument.Bookmarks(Index:="Position").Delete 900 | 901 | End Function 902 | 903 | ' ========================================================= 904 | Function HideHiddenText() 905 | ActiveDocument.ActiveWindow.View.ShowAll = False 906 | ActiveDocument.ActiveWindow.View.ShowHiddenText = False 907 | On Error GoTo endHidden 908 | With ActiveDocument.Styles("PlantUML") 909 | .Font.Hidden = True 910 | End With 911 | endHidden: 912 | On Error Resume Next 913 | End Function 914 | 915 | ' ========================================================= 916 | Function ShowHiddenText() 917 | ActiveDocument.ActiveWindow.View.ShowAll = False 918 | ActiveDocument.ActiveWindow.View.ShowHiddenText = True 919 | 920 | On Error GoTo endShow 921 | With ActiveDocument.Styles("PlantUML") 922 | .Font.Hidden = False 923 | End With 924 | endShow: 925 | On Error Resume Next 926 | End Function 927 | 928 | ' ========================================================= 929 | Function SwitchP() 930 | flag = Not (ActiveDocument.ActiveWindow.View.ShowTabs) 931 | ActiveDocument.ActiveWindow.View.ShowParagraphs = flag 932 | ActiveDocument.ActiveWindow.View.ShowTabs = flag 933 | ActiveDocument.ActiveWindow.View.ShowSpaces = flag 934 | ActiveDocument.ActiveWindow.View.ShowHyphens = flag 935 | ActiveDocument.ActiveWindow.View.ShowAll = False 936 | End Function 937 | 938 | ' ========================================================= 939 | ' \\ Function to return the full content of a text file as a string 940 | 'from http://www.vbaexpress.com/kb/getarticle.php?kb_id=699 941 | Function LoadTextFile(sFile) As String 942 | Dim iFile As Integer 943 | 944 | On Local Error Resume Next 945 | ' \\ Use FreeFile to supply a file number that is not already in use 946 | iFile = FreeFile 947 | 948 | ' \\ ' Open file for input. 949 | Open sFile For Input As #iFile 950 | 951 | ' \\ Return (Read) the whole content of the file to the function 952 | LoadTextFile = Input$(LOF(iFile), iFile) 953 | 954 | Close #iFile 955 | 956 | End Function 957 | 958 | 959 | 960 | Sub ISwitchP(ByVal Control As IRibbonControl) 961 | SwitchP 962 | End Sub 963 | 964 | Sub IShowPlantUML(ByVal Control As IRibbonControl) 965 | ShowPlantuml 966 | 967 | End Sub 968 | 969 | Sub IHidePlantUML(ByVal Control As IRibbonControl) 970 | HidePlantuml 971 | 972 | End Sub 973 | 974 | Sub IUML1(ByVal Control As IRibbonControl) 975 | Macro_UML ("parg") 976 | 977 | End Sub 978 | Sub IUMLAll(ByVal Control As IRibbonControl) 979 | Macro_UML ("all") 980 | End Sub 981 | 982 | Sub IAutoFormatOn(ByVal Control As IRibbonControl) 983 | AutoFormatOn 984 | End Sub 985 | Sub IAutoFormatOff(ByVal Control As IRibbonControl) 986 | AutoFormatOff 987 | End Sub 988 | 989 | Sub IPlantUMLInteractive(ByVal Control As IRibbonControl) 990 | With frmPlantUMLInteractive 991 | 992 | 993 | .tbPlantCode.Text = Replace(Macro_UML("fetch"), vbLf, vbCrLf) 994 | 995 | .Show 996 | 997 | End With 998 | 999 | End Sub 1000 | 1001 | 1002 | 1003 | 1004 | 1005 | Sub IPreferences(ByVal Control As IRibbonControl) 1006 | Dim info As String 1007 | info = "Microsoft Word 2010 addin by Adriaan van den Brand" & vbCrLf & _ 1008 | "Plantuml: see http://plantuml.com" & vbCrLf & _ 1009 | "Graphviz path: " & getDotPath() & vbCrLf & _ 1010 | "Plantuml JAR: " & getJarPath() 1011 | 1012 | If RegKeyRead("VectorGraphics") = "ON" Then 1013 | vectorgraphics = True 1014 | End If 1015 | If RegKeyRead("FTPMode") = "ON" Then 1016 | useFTP = True 1017 | End If 1018 | FTPURL = RegKeyRead("URL") 1019 | 1020 | With PrefsForm 1021 | If vectorgraphics = True Then 1022 | .btnVectorGraphics.Caption = "ON" 1023 | Else 1024 | .btnVectorGraphics.Caption = "OFF" 1025 | End If 1026 | If useFTP = True Then 1027 | .btnFTP.Caption = "ON" 1028 | Else 1029 | .btnFTP.Caption = "OFF" 1030 | End If 1031 | 1032 | .info.Caption = info 1033 | .Show 1034 | RegKeySave "VectorGraphics", .btnVectorGraphics.Caption 1035 | RegKeySave "FTPMode", .btnFTP.Caption 1036 | RegKeySave "FTPURL", .tbURL.Text 1037 | 1038 | ' adjust setting, will even work if registry saving failed 1039 | vectorgraphics = (.btnVectorGraphics.Caption = "ON") 1040 | useFTP = (.btnFTP.Caption = "ON") 1041 | FTPURL = (.tbURL.Text) 1042 | 1043 | End With 1044 | End Sub 1045 | 1046 | Sub AutoFormatOff() 1047 | ' disable worst of MS Word autoformatting options 1048 | With options 1049 | .AutoFormatAsYouTypeReplaceQuotes = False 1050 | .AutoFormatAsYouTypeReplaceSymbols = False 1051 | .AutoFormatAsYouTypeReplacePlainTextEmphasis = False 1052 | .AutoFormatAsYouTypeDefineStyles = False 1053 | .TabIndentKey = True 1054 | End With 1055 | End Sub 1056 | 1057 | Sub AutoFormatOn() 1058 | ' enable disabled MS Word autoformatting options 1059 | With options 1060 | .AutoFormatAsYouTypeReplaceQuotes = True 1061 | .AutoFormatAsYouTypeReplaceSymbols = True 1062 | .AutoFormatAsYouTypeReplacePlainTextEmphasis = True 1063 | .AutoFormatAsYouTypeDefineStyles = True 1064 | .TabIndentKey = True 1065 | End With 1066 | End Sub 1067 | 1068 | 1069 | 1070 | 1071 | -------------------------------------------------------------------------------- /Template_Word_2016/module/PlantumlFTP: -------------------------------------------------------------------------------- 1 | Const ASCII_TRANSFER = 1 2 | Const BINARY_TRANSFER = 2 3 | Const INTERNET_FLAG_RELOAD = &H80000000 4 | Const UserName = "plantuml" 5 | Const Pass = "plantuml" 6 | Const useFTP = True 7 | 8 | 'Open the Internet object 9 | Private Declare PtrSafe Function InternetOpen _ 10 | Lib "wininet.dll" _ 11 | Alias "InternetOpenA" _ 12 | (ByVal sAgent As String, _ 13 | ByVal lAccessType As Long, _ 14 | ByVal sProxyName As String, _ 15 | ByVal sProxyBypass As String, _ 16 | ByVal lFlags As Long) As Long 17 | 18 | 'Connect to the network 19 | Private Declare PtrSafe Function InternetConnect _ 20 | Lib "wininet.dll" _ 21 | Alias "InternetConnectA" _ 22 | (ByVal hInternetSession As Long, _ 23 | ByVal sServerName As String, _ 24 | ByVal nServerPort As Integer, _ 25 | ByVal sUsername As String, _ 26 | ByVal sPassword As String, _ 27 | ByVal lService As Long, _ 28 | ByVal lFlags As Long, _ 29 | ByVal lContext As Long) As Long 30 | 31 | 'Get a file using FTP 32 | Private Declare PtrSafe Function FtpGetFile _ 33 | Lib "wininet.dll" _ 34 | Alias "FtpGetFileA" _ 35 | (ByVal hFtpSession As Long, _ 36 | ByVal lpszRemoteFile As String, _ 37 | ByVal lpszNewFile As String, _ 38 | ByVal fFailIfExists As Boolean, _ 39 | ByVal dwFlagsAndAttributes As Long, _ 40 | ByVal dwFlags As Long, _ 41 | ByVal dwContext As Long) As Boolean 42 | 43 | 'Send a file using FTP 44 | Private Declare PtrSafe Function FtpPutFile _ 45 | Lib "wininet.dll" _ 46 | Alias "FtpPutFileA" _ 47 | (ByVal hFtpSession As Long, _ 48 | ByVal lpszLocalFile As String, _ 49 | ByVal lpszRemoteFile As String, _ 50 | ByVal dwFlags As Long, _ 51 | ByVal dwContext As Long) As Boolean 52 | 53 | 'Close the Internet object 54 | Private Declare PtrSafe Function InternetCloseHandle _ 55 | Lib "wininet.dll" _ 56 | (ByVal hInet As Long) As Integer 57 | 58 | 59 | Function testgetServerPort() 60 | Dim servername As String 61 | Dim serverport As Integer 62 | serverport = 123 63 | Debug.Assert getServerPort("127.0.0.1", servername, serverport) = True 64 | Debug.Assert servername = "127.0.0.1" 65 | Debug.Assert serverport = 123 66 | 67 | 68 | Debug.Assert getServerPort("127.0.0.1:4242", servername, serverport) = True 69 | Debug.Assert servername = "127.0.0.1" 70 | Debug.Assert serverport = 4242 71 | servername = "" 72 | serverport = 4242 73 | Debug.Assert getServerPort("127.0.0.1", servername, serverport) = True 74 | Debug.Assert servername = "127.0.0.1" 75 | Debug.Assert serverport = 4242 76 | 77 | Debug.Assert getServerPort("http://127.0.0.1:4242", servername, serverport) = False 78 | Debug.Assert getServerPort("www.nowhere.com:1234", servername, serverport) = True 79 | Debug.Assert servername = "www.nowhere.com" 80 | Debug.Assert serverport = 1234 81 | 82 | 83 | End Function 84 | 85 | Function getServerPort(url As String, ByRef servername As String, ByRef serverport As Integer) As Boolean 86 | Dim params() As String 87 | Dim RE As RegExp 88 | Dim match 89 | getServerPort = False 90 | Set RE = New RegExp 91 | url = LCase(url) 92 | If InStr("://", url) Then 93 | If Left(url, 6) = "ftp://" Then 94 | url = Mid(url, 7) 95 | Else 96 | Exit Function 97 | End If 98 | End If 99 | 100 | params = Split(url, ":") 101 | If UBound(params) <= 1 Then 102 | servername = params(0) 103 | If UBound(params) = 1 Then 104 | serverport = Val(params(1)) 105 | End If 106 | RE.Pattern = "[^:/\\ \t\n\r\%\&]+" 107 | If RE.Test(servername) And ((UBound(params) = 0) Or (serverport > 0)) Then 108 | getServerPort = True 109 | End If 110 | End If 111 | End Function 112 | 113 | Function ftpOpen(FTPURL As String) As Long 114 | Dim INet As Long 115 | Dim INetConn As Long 116 | Dim RetVal As Long 117 | Dim Success As Long 118 | Dim servername As String 119 | Dim serverport As Integer 120 | ftpOpen = 0 121 | INetConn = -1 122 | serverport = 4242 ' default 123 | If getServerPort(FTPURL, servername, serverport) Then 124 | 125 | INet = InternetOpen("MyFTP Control", 1&, vbNullString, vbNullString, 0&) 126 | If INet > 0 Then 127 | INetConn = InternetConnect(INet, servername, serverport, UserName, Pass, 1&, 0&, 0&) 128 | ftpOpen = INetConn 129 | Debug.Print "FtpOpen(" & FTPURL & ") -> success" 130 | Else 131 | Debug.Print "FtpOpen(" & FTPURL & ") -> failed" 132 | End If 133 | Else 134 | Debug.Print "FtpOpen(" & FTPURL & ") -> ill configured server/port" 135 | End If 136 | End Function 137 | 138 | Function ftpClose(handle As Long) 139 | If handle > 0 Then 140 | RetVal = InternetCloseHandle(handle) 141 | End If 142 | Debug.Print "FtpClose(" & handle & ")" 143 | End Function 144 | ' ========================================================= 145 | ' Store a File to a FTP server 146 | Function FtpStor(INetConn As Long, localFile, hostFile) 147 | 148 | Dim RetVal As Long 149 | Dim Success As Long 150 | 151 | RetVal = False 152 | FtpStor = True 153 | 154 | If INetConn > 0 Then 155 | Success = FtpPutFile(INetConn, localFile, hostFile, BINARY_TRANSFER Or INTERNET_FLAG_RELOAD, 0&) 156 | FtpStor = True 157 | End If 158 | Debug.Print "FtpStor(" & localFile & " , " & hostFile & ") -> " & RetVal & "success=" & Success 159 | 160 | End Function 161 | 162 | 163 | ' ========================================================= 164 | ' Retrieve a File from a FTP server 165 | Function FtpRetr(INetConn As Long, localFile, hostFile) 166 | 167 | Dim INet As Long 168 | Dim RetVal As Long 169 | Dim Success As Long 170 | 171 | RetVal = False 172 | FtpRetr = RetVal 173 | If INetConn > 0 Then 174 | FtpRetr = True 175 | Success = FtpGetFile(INetConn, hostFile, localFile, False, 0, BINARY_TRANSFER Or INTERNET_FLAG_RELOAD, 0&) 176 | Debug.Print "FtpRetr(" & localFile & " , " & hostFile & ") -> " & Success 177 | 178 | End If 179 | 180 | End Function 181 | 182 | 183 | 184 | 185 | ' ========================================================= 186 | 187 | Function Macro_UML(scope) 188 | ' Generate diagrams image from a PlantUML source textual description in the Word Document 189 | ' Scope can be "parg" or "all" 190 | ' 191 | ' - Initialisations 192 | ' 193 | Call ToolbarInit 194 | Set statusButton = CommandBars("UML").Controls(6) 195 | 196 | Call CreateStyle 197 | Call CreateStyleImg 198 | Call ShowPlantuml 199 | 200 | Call ShowHiddenText 201 | Selection.Range.Select 202 | ' 203 | ' documentId is the filename with its path, without extension 204 | ' 205 | documentId = ActiveDocument.Name 206 | documentId = Left(documentId, Len(documentId) - 4) 207 | 208 | ' Check for the presente of plantuml.jar 209 | 210 | Set fs = CreateObject("Scripting.FileSystemObject") 211 | jarPath = getJarPath() 212 | If fs.FileExists(jarPath & "\plantuml.jar") = False Then 213 | MsgBox jarPath 214 | GoTo Macro_UML_exit 215 | End If 216 | 217 | ' - Phase 1 218 | ' We create a file text per bloc of diagrams 219 | ' We look for @startuml 220 | ' We open the textfile in background (visible:=false) 221 | ' We add to the name a number on 4 digit 222 | ' The text bloc is put on "PlantUML" style 223 | ' Then the bloc is copied into the text file 224 | 225 | statusButton.Caption = "Extract" 226 | statusButton.Visible = False 227 | statusButton.Visible = True 228 | If scope = "all" Then 229 | Set parsedtext = ActiveDocument.Content 230 | isForward = True 231 | Else 232 | Set parsedtext = Selection.Range 233 | parsedtext.Collapse 234 | isForward = False 235 | End If 236 | 237 | parsedtext.Find.Execute FindText:=startuml, Forward:=isForward 238 | If parsedtext.Find.Found = True Then 239 | 'We keep the the first line only "@startuml" with the carriage return 240 | Set singleparagraph = parsedtext.Paragraphs(1).Range 241 | singleparagraph.Collapse 242 | Else 243 | GoTo Macro_UML_exit 244 | End If 245 | 246 | Do While parsedtext.Find.Found = True And _ 247 | (scope = "all" Or currentIndex < 1) 248 | statusButton.Caption = "Extract." & currentIndex + 1 249 | statusButton.Visible = False 250 | statusButton.Visible = True 251 | Set currentparagraph = parsedtext.Paragraphs(1) 252 | Set paragraphRange = currentparagraph.Range 253 | paragraphRange.Collapse 254 | jobDone = False 255 | Do Until jobDone 256 | If Left(currentparagraph.Range.Text, Len(startuml)) = startuml Then 257 | Set paragraphRange = currentparagraph.Range 258 | paragraphRange.Collapse 259 | 260 | End If 261 | paragraphRange.MoveEnd Unit:=wdParagraph 262 | If Left(currentparagraph.Range.Text, Len(enduml)) = enduml Then 263 | paragraphRange.Style = "PlantUML" 264 | paragraphRange.Copy 265 | Set textFile = Documents.Add(Visible:=False) 266 | textFile.Content.Paste 267 | currentIndex = currentIndex + 1 268 | textFileId = documentId & "_extr" & Right("000" & currentIndex, 4) & ".txt" 269 | textFile.SaveAs filename:=jarPath & "\" & textFileId, FileFormat:=wdFormatText, Encoding:=65001 270 | textFile.Close 271 | If useFTP Then 272 | retValue = FtpStor(jarPath & "\" & textFileId, textFileId) 273 | 'MsgBox ("A") 274 | 'imageId = Left(textFileId, Len(textFileId) - 4) & ".png" 275 | 'imageName = jarPath & "\" & imageId 276 | 'retValue = FtpRetr(imageName, imageId) 277 | 'MsgBox ("B") 278 | End If 279 | jobDone = True 280 | End If 281 | 282 | Set currentparagraph = currentparagraph.Next 283 | 284 | If currentparagraph Is Nothing Then 285 | jobDone = True 286 | End If 287 | Loop 288 | parsedtext.Collapse Direction:=wdCollapseEnd 289 | If scope = "all" Then 290 | parsedtext.Find.Execute FindText:=startuml, Forward:=True 291 | End If 292 | Loop 293 | ' 294 | ' We create a lock file that will be deleted by the Java program to indicate the end of Java process 295 | ' 296 | statusButton.Caption = "Gener" 297 | statusButton.Visible = False 298 | statusButton.Visible = True 299 | Set lockFile = Documents.Add(Visible:=False) 300 | lockFile.SaveAs filename:=jarPath & "\javaumllock.tmp", FileFormat:=wdFormatText 301 | lockFile.Close 302 | 303 | ' 304 | ' Call to PlantUML to generate images from text descriptions 305 | ' 306 | If useFTP Then 307 | For I = 1 To currentIndex 308 | imageId = documentId & "_extr" & Right("000" & I, 4) & ".png" 309 | imageName = jarPath & "\" & imageId 310 | retValue = FtpRetr(imageName, imageId) 311 | Next I 312 | 'Sleep 200 313 | End If 314 | 315 | If useFTP = False Then 316 | JavaCommand = "java -classpath """ & jarPath & "\plantuml.jar;" & _ 317 | jarPath & "\plantumlskins.jar"" net.sourceforge.plantuml.Run -charset UTF8 -word """ & jarPath & "/""" 318 | Shell (JavaCommand) 319 | ' This sleep is needed, but we don't know why... 320 | Sleep 500 321 | ' 322 | ' Phase 2 : 323 | ' Insertion of images into the word document 324 | ' We insert the image after the textual block that describe the diagram 325 | ' 326 | jobDone = False 327 | currentIndex = 0 328 | 329 | ' We wait for the file javaumllock.tmp to be deleted by Java 330 | ' which means that the process is ended 331 | ' 332 | Do 333 | currentIndex = currentIndex + 1 334 | statusButton.Caption = "Gener." & currentIndex 335 | statusButton.Visible = False 336 | statusButton.Visible = True 337 | DoEvents 338 | Sleep 1000 339 | If fs.FileExists(jarPath & "\javaumllock.tmp") = False Then 340 | jobDone = True 341 | Exit Do 342 | End If 343 | If currentIndex > 30 Then 344 | statusButton.Visible = False 345 | MsgBox ("Java Timeout. Aborted.") 346 | Exit Do 347 | End If 348 | Loop 349 | 350 | If jobDone = False Then 351 | End 352 | End If 353 | End If 354 | 355 | statusButton.Caption = "Inser" 356 | statusButton.Visible = False 357 | statusButton.Visible = True 358 | 359 | If scope = "all" Then 360 | Set parsedtext = ActiveDocument.Content 361 | isForward = True 362 | Else 363 | Set parsedtext = singleparagraph 364 | isForward = True 365 | End If 366 | parsedtext.Find.Execute FindText:=enduml, Forward:=isForward 367 | currentIndex = 0 368 | Do While parsedtext.Find.Found = True And (scope = "all" Or currentIndex < 1) 369 | currentIndex = currentIndex + 1 370 | statusButton.Caption = "Inser." & currentIndex 371 | statusButton.Visible = False 372 | statusButton.Visible = True 373 | On Error GoTo LastParagraph 374 | Set currentparagraph = parsedtext.Paragraphs(1).Next.Range 375 | Do While currentparagraph.InlineShapes.Count > 0 And currentparagraph.Style = "PlantUMLImg" 376 | currentparagraph.Delete 377 | Set currentparagraph = parsedtext.Paragraphs(1).Next.Range 378 | Loop 379 | On Error GoTo 0 380 | Set currentRange = currentparagraph 381 | imagesDirectory = jarPath & "\" & documentId & "_extr" & Right("000" & currentIndex, 4) & "*.png" 382 | image = Dir(imagesDirectory) 383 | While image <> "" 384 | Set currentparagraph = ActiveDocument.Paragraphs.Add(Range:=currentRange).Range 385 | Set currentRange = currentparagraph.Paragraphs(1).Next.Range 386 | currentparagraph.Style = "PlantUMLImg" 387 | currentparagraph.Collapse 388 | 389 | Set image = currentparagraph.InlineShapes.AddPicture _ 390 | (filename:=jarPath & "\" & image _ 391 | , LinkToFile:=False, SaveWithDocument:=True) 392 | image.AlternativeText = "Generated by PlantUML" 393 | If image.ScaleHeight > 100 Or image.ScaleWidth > 100 Then 394 | image.Reset 395 | End If 396 | image = Dir() 397 | Wend 398 | parsedtext.Collapse Direction:=wdCollapseEnd 399 | parsedtext.Find.Execute FindText:=enduml, Forward:=True 400 | Loop 401 | 402 | ' 403 | ' Phase 3 : suppression of temporary files (texte and PNG) 404 | ' 405 | Phase3: 406 | statusButton.Caption = "Delete" 407 | statusButton.Visible = False 408 | statusButton.Visible = True 409 | On Error Resume Next 410 | Kill (jarPath & "\" & documentId & "_extr*.*") 411 | On Error GoTo 0 412 | 413 | Macro_UML_exit: 414 | 415 | statusButton.Visible = False 416 | 417 | 'We show the hidden description text 418 | Call ShowHiddenText 419 | DoubleCheckStyle 420 | Exit Function 421 | 422 | 423 | ' This is need when the very last line of the Word document is @enduml 424 | LastParagraph: 425 | Selection.EndKey Unit:=wdStory 426 | Selection.TypeParagraph 427 | Selection.ClearFormatting 428 | 429 | imagesDirectory = jarPath & "\" & documentId & "_extr" & Right("000" & currentIndex, 4) & "*.png" 430 | image = Dir(imagesDirectory) 431 | While image <> "" 432 | Set currentparagraph = ActiveDocument.Paragraphs.Add.Range 433 | Set currentRange = currentparagraph.Paragraphs(1).Next.Range 434 | currentparagraph.Style = "PlantUMLImg" 435 | currentparagraph.Collapse 436 | 437 | Set image = currentparagraph.InlineShapes.AddPicture _ 438 | (filename:=jarPath & "\" & image _ 439 | , LinkToFile:=False, SaveWithDocument:=True) 440 | image.AlternativeText = "Generated by PlantUML" 441 | If image.ScaleHeight > 100 Or image.ScaleWidth > 100 Then 442 | image.Reset 443 | End If 444 | image = Dir() 445 | Wend 446 | 447 | 'Resume Next 448 | GoTo Phase3 449 | 450 | End Function 451 | 452 | ' ========================================================= 453 | ' Initialize the plantuml ToolBar 454 | Function ToolbarInit() 455 | 456 | On Error GoTo ToolbarCreation 457 | Set toolBar = ActiveDocument.CommandBars("UML") 458 | On Error GoTo 0 459 | toolBar.Visible = True 460 | 461 | On Error GoTo ButtonAdd 462 | Set currentButton = toolBar.Controls(1) 463 | On Error GoTo 0 464 | currentButton.OnAction = "Module1.SwitchP" 465 | currentButton.Style = msoButtonCaption 466 | currentButton.Caption = Chr(182) 467 | currentButton.Visible = True 468 | 469 | On Error GoTo ButtonAdd 470 | Set currentButton = toolBar.Controls(2) 471 | On Error GoTo 0 472 | currentButton.OnAction = "Module1.ShowPlantuml" 473 | currentButton.Style = msoButtonCaption 474 | currentButton.Caption = "Show PlantUML" 475 | currentButton.Visible = True 476 | 477 | On Error GoTo ButtonAdd 478 | Set currentButton = toolBar.Controls(3) 479 | On Error GoTo 0 480 | currentButton.OnAction = "Module1.HidePlantuml" 481 | currentButton.Style = msoButtonCaption 482 | currentButton.Caption = "Hide PlantUML" 483 | currentButton.Visible = True 484 | 485 | On Error GoTo ButtonAdd 486 | Set currentButton = toolBar.Controls(4) 487 | On Error GoTo 0 488 | currentButton.OnAction = "Module1.Macro_UML_all" 489 | currentButton.Style = msoButtonCaption 490 | currentButton.Caption = "UML.*" 491 | currentButton.Visible = True 492 | 493 | On Error GoTo ButtonAdd 494 | Set currentButton = toolBar.Controls(5) 495 | On Error GoTo 0 496 | currentButton.OnAction = "Module1.Macro_UML_parg" 497 | currentButton.Style = msoButtonCaption 498 | currentButton.Caption = "UML.1" 499 | currentButton.Visible = True 500 | 501 | On Error GoTo ButtonAdd 502 | Set currentButton = toolBar.Controls(6) 503 | On Error GoTo 0 504 | currentButton.OnAction = "" 505 | currentButton.Style = msoButtonCaption 506 | currentButton.Caption = "Trace" 507 | currentButton.Visible = True 508 | Exit Function 509 | 510 | ToolbarCreation: 511 | Set toolBar = ActiveDocument.CommandBars.Add(Name:="UML") 512 | Resume Next 513 | 514 | ButtonAdd: 515 | Set currentButton = toolBar.Controls.Add(Type:=msoControlButton, Before:=toolBar.Controls.Count + 1) 516 | Resume Next 517 | 518 | End Function 519 | 520 | ' ========================================================= 521 | ' We need to double check that the style is present in the document 522 | Function DoubleCheckStyle() 523 | CreateStyle 524 | CreateStyleImg 525 | Set mystyle = ActiveDocument.Styles("PlantUML") 526 | mystyle.BaseStyle = ActiveDocument.Styles.Item(1).BaseStyle 527 | 528 | mystyle.AutomaticallyUpdate = True 529 | With mystyle.Font 530 | .Name = "Courier New" 531 | .Size = 9 532 | .Hidden = False 533 | .Hidden = True 534 | .Color = wdColorGreen 535 | End With 536 | End Function 537 | 538 | ' ========================================================= 539 | Function CreateStyle() 540 | On Error GoTo CreateStyleAdding 541 | Set mystyle = ActiveDocument.Styles("PlantUML") 542 | Exit Function 543 | CreateStyleAdding: 544 | Set mystyle = ActiveDocument.Styles.Add(Name:="PlantUML", Type:=wdStyleTypeParagraph) 545 | mystyle.BaseStyle = ActiveDocument.Styles.Item(1).BaseStyle 546 | mystyle.AutomaticallyUpdate = True 547 | With mystyle.Font 548 | .Name = "Courier New" 549 | .Size = 9 550 | .Hidden = False 551 | .Hidden = True 552 | .Color = wdColorGreen 553 | End With 554 | With mystyle.ParagraphFormat 555 | With .Shading 556 | .Texture = wdTextureNone 557 | .ForegroundPatternColor = wdColorAutomatic 558 | .BackgroundPatternColor = wdColorLightGreen 559 | End With 560 | 561 | .LeftIndent = CentimetersToPoints(0) 562 | With .Shading 563 | .Texture = wdTextureNone 564 | .ForegroundPatternColor = wdColorAutomatic 565 | .BackgroundPatternColor = 12254650 566 | End With 567 | With .Borders(wdBorderLeft) 568 | .LineStyle = wdLineStyleDashLargeGap 569 | .LineWidth = wdLineWidth050pt 570 | .Color = 3910491 571 | End With 572 | With .Borders(wdBorderRight) 573 | .LineStyle = wdLineStyleDashLargeGap 574 | .LineWidth = wdLineWidth050pt 575 | .Color = 3910491 576 | End With 577 | With .Borders(wdBorderTop) 578 | .LineStyle = wdLineStyleDashLargeGap 579 | .LineWidth = wdLineWidth050pt 580 | .Color = 3910491 581 | End With 582 | With .Borders(wdBorderBottom) 583 | .LineStyle = wdLineStyleDashLargeGap 584 | .LineWidth = wdLineWidth050pt 585 | .Color = 3910491 586 | End With 587 | With .Borders 588 | .DistanceFromTop = 1 589 | .DistanceFromLeft = 4 590 | .DistanceFromBottom = 1 591 | .DistanceFromRight = 4 592 | .Shadow = False 593 | End With 594 | End With 595 | 596 | ' ajout des tabulations 597 | mystyle.NoSpaceBetweenParagraphsOfSameStyle = False 598 | mystyle.ParagraphFormat.TabStops.ClearAll 599 | mystyle.ParagraphFormat.TabStops.Add Position:= _ 600 | CentimetersToPoints(1), Alignment:=wdAlignTabLeft, Leader:=wdTabLeaderSpaces 601 | mystyle.ParagraphFormat.TabStops.Add Position:= _ 602 | CentimetersToPoints(2), Alignment:=wdAlignTabLeft, Leader:=wdTabLeaderSpaces 603 | mystyle.ParagraphFormat.TabStops.Add Position:= _ 604 | CentimetersToPoints(3), Alignment:=wdAlignTabLeft, Leader:=wdTabLeaderSpaces 605 | mystyle.ParagraphFormat.TabStops.Add Position:= _ 606 | CentimetersToPoints(4), Alignment:=wdAlignTabLeft, Leader:=wdTabLeaderSpaces 607 | 608 | 609 | End Function 610 | 611 | ' ========================================================= 612 | Function CreateStyleImg() 613 | On Error GoTo CreateStyleImgAdding 614 | Set mystyle = ActiveDocument.Styles("PlantUMLImg") 615 | mystyle.BaseStyle = ActiveDocument.Styles.Item(1).BaseStyle 616 | On Error GoTo 0 617 | Exit Function 618 | CreateStyleImgAdding: 619 | Set mystyle = ActiveDocument.Styles.Add(Name:="PlantUMLImg", Type:=wdStyleTypeParagraph) 620 | mystyle.AutomaticallyUpdate = True 621 | End Function 622 | 623 | ' ========================================================= 624 | ' We show the hidden text 625 | Function ShowPlantuml() 626 | DoubleCheckStyle 627 | 628 | 'WordBasic.ShowComments 629 | ' We put a bookmark to retrieve position after showing the text 630 | ActiveDocument.Bookmarks.Add Name:="Position", Range:=Selection.Range 631 | 632 | Set mystyle = ActiveDocument.Styles("PlantUML") 633 | Set toolBar = ActiveDocument.CommandBars("UML") 634 | 635 | toolBar.Controls(2).Visible = False 636 | toolBar.Controls(3).Visible = True 637 | toolBar.Controls(4).Visible = True 638 | toolBar.Controls(5).Visible = True 639 | 640 | Call ShowHiddenText 641 | 642 | 'We go back to the bookmark and we delete it 643 | Selection.GoTo What:=wdGoToBookmark, Name:="Position" 644 | ActiveDocument.Bookmarks(Index:="Position").Delete 645 | 646 | End Function 647 | 648 | 649 | ' ========================================================= 650 | ' MSR - gestion de l'option d'affichage des textes masques du style : "PlantUML" 651 | Function HidePlantuml() 652 | DoubleCheckStyle 653 | 'WordBasic.ShowComments 654 | ' We put a bookmark to retrieve position after showing the text 655 | ActiveDocument.Bookmarks.Add Name:="Position", Range:=Selection.Range 656 | 657 | Set mystyle = ActiveDocument.Styles("PlantUML") 658 | Set toolBar = ActiveDocument.CommandBars("UML") 659 | 660 | toolBar.Controls(2).Visible = True 661 | toolBar.Controls(3).Visible = False 662 | toolBar.Controls(4).Visible = False 663 | toolBar.Controls(5).Visible = False 664 | 665 | Call HideHiddenText 666 | 667 | 'We go back to the bookmark and we delete it 668 | Selection.GoTo What:=wdGoToBookmark, Name:="Position" 669 | ActiveDocument.Bookmarks(Index:="Position").Delete 670 | 671 | End Function 672 | 673 | ' ========================================================= 674 | Function HideHiddenText() 675 | ActiveDocument.ActiveWindow.View.ShowAll = False 676 | ActiveDocument.ActiveWindow.View.ShowHiddenText = False 677 | End Function 678 | 679 | ' ========================================================= 680 | Function ShowHiddenText() 681 | ActiveDocument.ActiveWindow.View.ShowAll = False 682 | ActiveDocument.ActiveWindow.View.ShowHiddenText = True 683 | End Function 684 | 685 | ' ========================================================= 686 | Function SwitchP() 687 | flag = Not (ActiveDocument.ActiveWindow.View.ShowTabs) 688 | ActiveDocument.ActiveWindow.View.ShowParagraphs = flag 689 | ActiveDocument.ActiveWindow.View.ShowTabs = flag 690 | ActiveDocument.ActiveWindow.View.ShowSpaces = flag 691 | ActiveDocument.ActiveWindow.View.ShowHyphens = flag 692 | ActiveDocument.ActiveWindow.View.ShowAll = False 693 | End Function 694 | 695 | 696 | 697 | 698 | 699 | 700 | -------------------------------------------------------------------------------- /Template_Word_2016/module/Registry: -------------------------------------------------------------------------------- 1 | 'from http://www.slipstick.com/developer/read-and-change-a-registry-key-using-vba/ 2 | 3 | 4 | Public Const basekey = "HKEY_CURRENT_USER\Software\PlantUML\" 5 | 'reads the value for the registry key i_RegKey 6 | 'if the key cannot be found, the return value is "" 7 | Function RegKeyRead(i_RegKey As String, Optional default As String) As String 8 | On Error Resume Next 9 | Dim myWS As Object 10 | If IsMissing(default) Then 11 | default = "" 12 | End If 13 | If Not RegKeyExists(basekey & i_RegKey) Then 14 | RegKeySave i_RegKey, default, "REG_SZ" 15 | End If 16 | On Error Resume Next 17 | 'access Windows scripting 18 | Set myWS = CreateObject("WScript.Shell") 19 | 'read key from registry 20 | RegKeyRead = myWS.RegRead(basekey & i_RegKey) 21 | On Error GoTo 0 22 | End Function 23 | 24 | 'sets the registry key i_RegKey to the 25 | 'value i_Value with type i_Type 26 | 'if i_Type is omitted, the value will be saved as string 27 | 'if i_RegKey wasn't found, a new registry key will be created 28 | 29 | ' change REG_DWORD to the correct key type 30 | Sub RegKeySave(i_RegKey As String, _ 31 | i_Value As String, _ 32 | Optional i_Type As String = "REG_SZ") 33 | Dim myWS As Object 34 | On Error Resume Next 35 | 36 | 'access Windows scripting 37 | Set myWS = CreateObject("WScript.Shell") 38 | 'write registry key 39 | myWS.RegWrite basekey & i_RegKey, i_Value, i_Type 40 | On Error GoTo 0 41 | End Sub 42 | 43 | 44 | 'returns True if the registry key i_RegKey was found 45 | 'and False if not 46 | Function RegKeyExists(i_RegKey As String) As Boolean 47 | Dim myWS As Object 48 | 49 | On Error GoTo ErrorHandler 50 | 'access Windows scripting 51 | Set myWS = CreateObject("WScript.Shell") 52 | 'try to read the registry key 53 | myWS.RegRead i_RegKey 54 | 'key was found 55 | RegKeyExists = True 56 | On Error GoTo 0 57 | Exit Function 58 | 59 | ErrorHandler: 60 | 'key was not found 61 | RegKeyExists = False 62 | On Error GoTo 0 63 | End Function 64 | 65 | -------------------------------------------------------------------------------- /Template_Word_2016/module/ShellUtil: -------------------------------------------------------------------------------- 1 | Option Explicit 2 | Option Compare Text 3 | 4 | ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 5 | ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 6 | ' modShellAndWait 7 | ' By Chip Pearson, chip@cpearson.com, www.cpearson.com 8 | ' This page on the web site: www.cpearson.com/Excel/ShellAndWait.aspx 9 | ' 9-September-2008 10 | ' 11 | ' This module contains code for the ShellAndWait function that will Shell to a process 12 | ' and wait for that process to end before returning to the caller. 13 | 14 | ' 64 bit fix provided by Andreas Brusinsky, Gil Fuchs, Ren Vleer : Thanks. 15 | ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 16 | ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 17 | #If Win64 Or VBA7 Then 18 | Private Declare PtrSafe Function WaitForSingleObject Lib "kernel32" ( _ 19 | ByVal hHandle As LongPtr, _ 20 | ByVal dwMilliseconds As Long) As Long 21 | 22 | Private Declare PtrSafe Function OpenProcess Lib "kernel32.dll" ( _ 23 | ByVal dwDesiredAccess As Long, _ 24 | ByVal bInheritHandle As Long, _ 25 | ByVal dwProcessId As Long) As Long 26 | 27 | Private Declare PtrSafe Function CloseHandle Lib "kernel32" ( _ 28 | ByVal hObject As Long) As Long 29 | #Else 30 | Private Declare PtrSafe Function WaitForSingleObject Lib "kernel32" ( _ 31 | ByVal hHandle As LongPtr, _ 32 | ByVal dwMilliseconds As Long) As Long 33 | 34 | Private Declare PtrSafe Function OpenProcess Lib "kernel32.dll" ( _ 35 | ByVal dwDesiredAccess As Long, _ 36 | ByVal bInheritHandle As Long, _ 37 | ByVal dwProcessId As Long) As Long 38 | 39 | Private Declare PtrSafe Function CloseHandle Lib "kernel32" ( _ 40 | ByVal hObject As Long) As Long 41 | #End If 42 | 43 | Private Const SYNCHRONIZE = &H100000 44 | 45 | Public Enum ShellAndWaitResult 46 | Success = 0 47 | Failure = 1 48 | TimeOut = 2 49 | InvalidParameter = 3 50 | SysWaitAbandoned = 4 51 | UserWaitAbandoned = 5 52 | UserBreak = 6 53 | End Enum 54 | 55 | Public Enum ActionOnBreak 56 | IgnoreBreak = 0 57 | AbandonWait = 1 58 | PromptUser = 2 59 | End Enum 60 | 61 | Private Const STATUS_ABANDONED_WAIT_0 As Long = &H80 62 | Private Const STATUS_WAIT_0 As Long = &H0 63 | Private Const WAIT_ABANDONED As Long = (STATUS_ABANDONED_WAIT_0 + 0) 64 | Private Const WAIT_OBJECT_0 As Long = (STATUS_WAIT_0 + 0) 65 | Private Const WAIT_TIMEOUT As Long = 258& 66 | Private Const WAIT_FAILED As Long = &HFFFFFFFF 67 | Private Const WAIT_INFINITE = -1& 68 | 69 | 70 | Public Function ShellAndWait(ShellCommand As String, _ 71 | TimeOutMs As Long, _ 72 | ShellWindowState As VbAppWinStyle, _ 73 | BreakKey As ActionOnBreak) As ShellAndWaitResult 74 | ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 75 | ' ShellAndWait 76 | ' 77 | ' This function calls Shell and passes to it the command text in ShellCommand. The function 78 | ' then waits for TimeOutMs (in milliseconds) to expire. 79 | ' 80 | ' Parameters: 81 | ' ShellCommand 82 | ' is the command text to pass to the Shell function. 83 | ' 84 | ' TimeOutMs 85 | ' is the number of milliseconds to wait for the shell'd program to wait. If the 86 | ' shell'd program terminates before TimeOutMs has expired, the function returns 87 | ' ShellAndWaitResult.Success = 0. If TimeOutMs expires before the shell'd program 88 | ' terminates, the return value is ShellAndWaitResult.TimeOut = 2. 89 | ' 90 | ' ShellWindowState 91 | ' is an item in VbAppWinStyle specifying the window state for the shell'd program. 92 | ' 93 | ' BreakKey 94 | ' is an item in ActionOnBreak indicating how to handle the application's cancel key 95 | ' (Ctrl Break). If BreakKey is ActionOnBreak.AbandonWait and the user cancels, the 96 | ' wait is abandoned and the result is ShellAndWaitResult.UserWaitAbandoned = 5. 97 | ' If BreakKey is ActionOnBreak.IgnoreBreak, the cancel key is ignored. If 98 | ' BreakKey is ActionOnBreak.PromptUser, the user is given a ?Continue? message. If the 99 | ' user selects "do not continue", the function returns ShellAndWaitResult.UserBreak = 6. 100 | ' If the user selects "continue", the wait is continued. 101 | ' 102 | ' Return values: 103 | ' ShellAndWaitResult.Success = 0 104 | ' indicates the the process completed successfully. 105 | ' ShellAndWaitResult.Failure = 1 106 | ' indicates that the Wait operation failed due to a Windows error. 107 | ' ShellAndWaitResult.TimeOut = 2 108 | ' indicates that the TimeOutMs interval timed out the Wait. 109 | ' ShellAndWaitResult.InvalidParameter = 3 110 | ' indicates that an invalid value was passed to the procedure. 111 | ' ShellAndWaitResult.SysWaitAbandoned = 4 112 | ' indicates that the system abandoned the wait. 113 | ' ShellAndWaitResult.UserWaitAbandoned = 5 114 | ' indicates that the user abandoned the wait via the cancel key (Ctrl+Break). 115 | ' This happens only if BreakKey is set to ActionOnBreak.AbandonWait. 116 | ' ShellAndWaitResult.UserBreak = 6 117 | ' indicates that the user broke out of the wait after being prompted with 118 | ' a ?Continue message. This happens only if BreakKey is set to 119 | ' ActionOnBreak.PromptUser. 120 | ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 121 | 122 | Dim TaskID As Long 123 | Dim ProcHandle As Long 124 | Dim WaitRes As Long 125 | Dim Ms As Long 126 | Dim MsgRes As VbMsgBoxResult 127 | ' Dim SaveCancelKey As WdEnableCancelKey 128 | Dim ElapsedTime As Long 129 | Dim Quit As Boolean 130 | Const ERR_BREAK_KEY = 18 131 | Const DEFAULT_POLL_INTERVAL = 500 132 | 133 | If Trim(ShellCommand) = vbNullString Then 134 | ShellAndWait = ShellAndWaitResult.InvalidParameter 135 | Exit Function 136 | End If 137 | 138 | If TimeOutMs < 0 Then 139 | ShellAndWait = ShellAndWaitResult.InvalidParameter 140 | Exit Function 141 | ElseIf TimeOutMs = 0 Then 142 | Ms = WAIT_INFINITE 143 | Else 144 | Ms = TimeOutMs 145 | End If 146 | 147 | Select Case BreakKey 148 | Case AbandonWait, IgnoreBreak, PromptUser 149 | ' valid 150 | Case Else 151 | ShellAndWait = ShellAndWaitResult.InvalidParameter 152 | Exit Function 153 | End Select 154 | 155 | Select Case ShellWindowState 156 | Case vbHide, vbMaximizedFocus, vbMinimizedFocus, vbMinimizedNoFocus, vbNormalFocus, vbNormalNoFocus 157 | ' valid 158 | Case Else 159 | ShellAndWait = ShellAndWaitResult.InvalidParameter 160 | Exit Function 161 | End Select 162 | 163 | On Error Resume Next 164 | Err.Clear 165 | TaskID = Shell(ShellCommand, ShellWindowState) 166 | If (Err.Number <> 0) Or (TaskID = 0) Then 167 | ShellAndWait = ShellAndWaitResult.Failure 168 | Exit Function 169 | End If 170 | 171 | ProcHandle = OpenProcess(SYNCHRONIZE, False, TaskID) 172 | If ProcHandle = 0 Then 173 | ShellAndWait = ShellAndWaitResult.Failure 174 | Exit Function 175 | End If 176 | 177 | On Error GoTo ErrH: 178 | ' SaveCancelKey = Application.EnableCancelKey 179 | ' Application.EnableCancelKey = xlErrorHandler 180 | WaitRes = WaitForSingleObject(ProcHandle, DEFAULT_POLL_INTERVAL) 181 | Do Until WaitRes = WAIT_OBJECT_0 182 | DoEvents 183 | Select Case WaitRes 184 | Case WAIT_ABANDONED 185 | ' Windows abandoned the wait 186 | ShellAndWait = ShellAndWaitResult.SysWaitAbandoned 187 | Exit Do 188 | Case WAIT_OBJECT_0 189 | ' Successful completion 190 | ShellAndWait = ShellAndWaitResult.Success 191 | Exit Do 192 | Case WAIT_FAILED 193 | ' attach failed 194 | ShellAndWait = ShellAndWaitResult.Failure 195 | Exit Do 196 | Case WAIT_TIMEOUT 197 | ' Wait timed out. Here, this time out is on DEFAULT_POLL_INTERVAL. 198 | ' See if ElapsedTime is greater than the user specified wait 199 | ' time out. If we have exceed that, get out with a TimeOut status. 200 | ' Otherwise, reissue as wait and continue. 201 | ElapsedTime = ElapsedTime + DEFAULT_POLL_INTERVAL 202 | If Ms > 0 Then 203 | ' user specified timeout 204 | If ElapsedTime > Ms Then 205 | ShellAndWait = ShellAndWaitResult.TimeOut 206 | Exit Do 207 | Else 208 | ' user defined timeout has not expired. 209 | End If 210 | Else 211 | ' infinite wait -- do nothing 212 | End If 213 | ' reissue the Wait on ProcHandle 214 | WaitRes = WaitForSingleObject(ProcHandle, DEFAULT_POLL_INTERVAL) 215 | 216 | Case Else 217 | ' unknown result, assume failure 218 | ShellAndWait = ShellAndWaitResult.Failure 219 | Exit Do 220 | Quit = True 221 | End Select 222 | Loop 223 | 224 | CloseHandle ProcHandle 225 | ' Application.EnableCancelKey = SaveCancelKey 226 | Exit Function 227 | 228 | ErrH: 229 | 'Debug.Print "ErrH: Cancel: " & Application.EnableCancelKey 230 | If Err.Number = ERR_BREAK_KEY Then 231 | If BreakKey = ActionOnBreak.AbandonWait Then 232 | CloseHandle ProcHandle 233 | ShellAndWait = ShellAndWaitResult.UserWaitAbandoned 234 | ' Application.EnableCancelKey = SaveCancelKey 235 | Exit Function 236 | ElseIf BreakKey = ActionOnBreak.IgnoreBreak Then 237 | Err.Clear 238 | Resume 239 | ElseIf BreakKey = ActionOnBreak.PromptUser Then 240 | MsgRes = MsgBox("User Process Break." & vbCrLf & _ 241 | "Continue to wait?", vbYesNo) 242 | If MsgRes = vbNo Then 243 | CloseHandle ProcHandle 244 | ShellAndWait = ShellAndWaitResult.UserBreak 245 | ' Application.EnableCancelKey = SaveCancelKey 246 | Else 247 | Err.Clear 248 | Resume Next 249 | End If 250 | Else 251 | CloseHandle ProcHandle 252 | ' Application.EnableCancelKey = SaveCancelKey 253 | ShellAndWait = ShellAndWaitResult.Failure 254 | End If 255 | Else 256 | ' some other error. assume failure 257 | CloseHandle ProcHandle 258 | ShellAndWait = ShellAndWaitResult.Failure 259 | End If 260 | 261 | ' Application.EnableCancelKey = SaveCancelKey 262 | 263 | End Function 264 | 265 | -------------------------------------------------------------------------------- /images/menu.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/plantuml/word-template/ae00c5684e9cb2e66386cdfc08cda318385d454b/images/menu.png --------------------------------------------------------------------------------