VBCommons/api/API_VsoWrapper.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "API_VsoWrapper"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
' ================ <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>-<EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <EFBFBD><EFBFBD><EFBFBD> <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> MS Visio =========================
' Shared module version: 20220410
' Tested in: TestCommons
' Depends on:
' Required reference: Scripting, Visio
Option Explicit

Private Declare PtrSafe Function GetWindowThreadProcessId Lib "user32" (ByVal nHwnd As Long, nProcID As Long) As Long

Private application_ As Visio.Application
Private document_ As Visio.Document
Private reporter_ As Object
Private bSilent_ As Boolean

Private deferRel_ As Boolean
Private deferRecalc_ As Boolean
Private isPaused_ As Boolean

Private bCloseOnFail_ As Boolean
Private bOwnsDoc_ As Boolean
Private bOwnsApp_ As Boolean

Private Sub Class_Initialize()
  Call ResetAll
End Sub

Private Sub Class_Terminate()
  If application_ Is Nothing Then _
    Exit Sub
  ' Note: application could be owned by another Wrapper and already quit
  On Error GoTo SKIP_RELEASE
  If application_.Documents.Count = 0 Then _
    Call ReleaseApplication
SKIP_RELEASE:
End Sub

Public Function ResetAll()
  Call ResetDocument
  
  deferRel_ = False
  deferRecalc_ = False
  bSilent_ = False
End Function

Public Function ResetDocument()
  Set application_ = Nothing
  Set document_ = Nothing
  bOwnsDoc_ = False
  bOwnsApp_ = False
  bCloseOnFail_ = False
  isPaused_ = False
End Function

' Reporter object should implement callback function Report(sMsg$, nFlags&)
Public Function SetReporter(aReporter As Object)
  Set reporter_ = aReporter
End Function

Public Property Get Document() As Visio.Document
  Set Document = document_
End Property

Public Property Get Application() As Visio.Application
  Set Application = application_
End Property

Public Property Get IsUIPaused() As Boolean
  IsUIPaused = isPaused_
End Property

Public Function DisableMessages()
  bSilent_ = True
End Function

Public Function EnableMessages()
  bSilent_ = False
End Function

Public Function CreateApplication(Optional bIsVisible As Boolean = True) As Visio.Application
  Call ResetDocument
  Set application_ = CreateObject("Visio.Application")
  bOwnsApp_ = True
  application_.Visible = bIsVisible
  Set CreateApplication = application_
End Function

Public Function SetApplication(target As Visio.Application)
  If ObjPtr(application_) = ObjPtr(target) Then _
    Exit Function
  Call ResetDocument
  Set application_ = target
End Function

Public Function SetDocument(target As Visio.Document, Optional bOwnership = False)
  If ObjPtr(target) = ObjPtr(document_) Then
    bOwnsDoc_ = bOwnership
    Exit Function
  End If
  If Not target Is Nothing Then _
    Call SetApplication(target.Application)
  bOwnsDoc_ = bOwnership
  Set document_ = target
End Function

Public Function PauseUI()
  If application_ Is Nothing Then _
    Exit Function
  If document_ Is Nothing Then _
    Exit Function
    
  Debug.Assert Not isPaused_
  isPaused_ = True
  deferRel_ = application_.DeferRelationshipRecalc
  deferRecalc_ = application_.DeferRecalc
  application_.ScreenUpdating = False
  application_.DeferRecalc = True
  application_.DeferRelationshipRecalc = True
End Function

Public Function ResumeUI()
  If application_ Is Nothing Then _
    Exit Function
  If document_ Is Nothing Then _
    Exit Function
    
  isPaused_ = False
  application_.DeferRelationshipRecalc = deferRel_
  application_.DeferRecalc = deferRecalc_
  application_.ScreenUpdating = True
End Function

Public Function Run(sFunc$, ParamArray vArgs() As Variant)
  ' Note: running code in Visio cannot return value, so use file IO instead if needed (pass output filename through args)
  Dim nArgCount&: nArgCount = UBound(vArgs) - LBound(vArgs) + 1
  Dim sCommand$: sCommand = "Call " & sFunc & "("
  Dim nArg&
  For nArg = 0 To nArgCount - 1 Step 1
    If nArg <> 0 Then _
      sCommand = sCommand & ", "
    sCommand = sCommand & """" & CStr(vArgs(nArg)) & """"
  Next nArg
  sCommand = sCommand & ")"
  Call Document.ExecuteLine(sCommand)
End Function

Public Function NewDocument(Optional sTemplate$ = vbNullString, _
                            Optional bDefaultIfFail As Boolean = True) As Visio.Document
  If Not document_ Is Nothing Then _
    Exit Function
  
  If application_ Is Nothing Then
    bCloseOnFail_ = True
    Call CreateApplication
  End If
  
  On Error GoTo TRY_DEFAULT
  
  Set document_ = application_.Documents.Add(sTemplate)
  bOwnsDoc_ = True
  Set NewDocument = document_
  
  Exit Function
  
TRY_DEFAULT:
  If sTemplate <> vbNullString Then
    Call Report("<22><> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> " & sTemplate)
    If Not bDefaultIfFail Then
      If bCloseOnFail_ Then _
        Call ReleaseApplication
    Else
      On Error GoTo ERR_DEFAULT
      Set document_ = application_.Documents.Add("")
      Set NewDocument = document_
    End If
    Exit Function
  End If
  
ERR_DEFAULT:
  Call Report("<22><> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>")
  If bCloseOnFail_ Then _
    Call ReleaseApplication
End Function

Public Function OpenDocument(sFile$, Optional nOpenFlags As Integer = 0) As Visio.Document
' Note: <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> Visio <EFBFBD><EFBFBD> <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> <EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> ReadOnly
  If Not document_ Is Nothing Then _
    Exit Function
    
  Dim bResetApplication As Boolean
  bResetApplication = application_ Is Nothing
  If bResetApplication Then _
    Call DefaultApplication

  If TryAlreadyOpened(sFile) Then
    Set OpenDocument = document_
    Exit Function
  End If

  If Not TestFile(sFile) Then _
    GoTo SAFE_EXIT
  
  On Error GoTo SAFE_EXIT
  Set document_ = application_.Documents.OpenEx(sFile, nOpenFlags)
  On Error GoTo 0
  
  If Not document_ Is Nothing Then
    bOwnsDoc_ = True
    Set OpenDocument = document_
  Else
SAFE_EXIT:
    bOwnsDoc_ = False
    If bCloseOnFail_ Then _
      Call KillApplication
    If bResetApplication Then _
      Set application_ = Nothing
  End If
End Function

Public Function ReleaseApplication()
  If bOwnsApp_ Then _
    Call KillApplication
  Call ResetDocument
End Function

Public Function ReleaseDocument(Optional bCloseApplication As Boolean = True, _
                                Optional bSaveChanges As Boolean = False) As Boolean
  ReleaseDocument = False
  If document_ Is Nothing Then _
    Exit Function
  If Not bOwnsDoc_ Then
    Set document_ = Nothing
    ReleaseDocument = True
    Exit Function
  End If
  
  On Error GoTo EXIT_FUNC
  
  If (bSaveChanges And document_.Path <> vbNullString) Then
    Call document_.OpenStencilWindow
    Call document_.Save
  End If
  
  Dim nInitialResponse&: nInitialResponse = application_.AlertResponse
  application_.AlertResponse = vbNo
  Call document_.Close
  application_.AlertResponse = nInitialResponse
  
  On Error GoTo 0
  
  Set document_ = Nothing
  ReleaseDocument = True
 If bCloseApplication And application_.Documents.Count = 0 Then _
    Call ReleaseApplication
EXIT_FUNC:
End Function

Public Function SaveAs(sTargetName$) As Boolean
  SaveAs = False
  
  If document_ Is Nothing Then _
    Exit Function
  
  On Error GoTo RETURN_FALSE
  Call document_.SaveAs(sTargetName)
  On Error GoTo 0
  
  SaveAs = True
  Exit Function
RETURN_FALSE:
End Function

' ===========
Private Function Report(sMsg$)
  If bSilent_ Then
    Debug.Print "VisioWrapper: " & sMsg
    Exit Function
  ElseIf reporter_ Is Nothing Then
    Call MsgBox(sMsg, vbExclamation)
  Else
    Call reporter_.Report(sMsg, vbExclamation)
  End If
End Function

Private Function DefaultApplication()
  bOwnsApp_ = False
  On Error GoTo CREATE_NEW_APPL
  Set application_ = GetObject(, "Visio.Application")
  On Error GoTo 0
  Exit Function
  
CREATE_NEW_APPL:
  Set application_ = CreateObject("Visio.Application")
  bOwnsApp_ = True
  bCloseOnFail_ = True
  application_.Visible = True
End Function

Private Function KillApplication()
  Const HIDE_SHELL = 0
  Const WAIT_RETURN = True
  
  On Error GoTo OFFICE_QUIT
  
  Dim nThreadID&, nProcID&
  nThreadID = GetWindowThreadProcessId(application_.WindowHandle32, nProcID)
  
  Dim iShell As Object: Set iShell = VBA.CreateObject("WScript.Shell")
  If iShell.Run("TaskKill /F /PID " & nProcID, HIDE_SHELL, WAIT_RETURN) = 0 Then _
    Exit Function

OFFICE_QUIT:
  Call application_.Quit
End Function

Private Function TryAlreadyOpened(sFile$) As Boolean
  TryAlreadyOpened = False
  
  Set document_ = FindByName(sFile)
  If document_ Is Nothing Then _
    Exit Function
  
  bOwnsDoc_ = False
  TryAlreadyOpened = True
End Function

Private Function TestFile(sFile$) As Boolean
  Const ATTRIBUTE_READONLY = 1
  TestFile = False

  Dim fso As New Scripting.FileSystemObject
  If Not fso.FileExists(sFile) Then
    Call Report("<22><><EFBFBD><EFBFBD> <20><> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD>: " & sFile)
    Exit Function
  End If
  
  If fso.GetFile(sFile).Attributes And ATTRIBUTE_READONLY Then
    Call Report("<22><><EFBFBD><EFBFBD> ReadOnly: " & sFile)
    Exit Function
  End If
  If IsFileInUse(sFile) Then
    Call Report("<22><><EFBFBD><EFBFBD> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>: " & sFile)
    Exit Function
  End If
  
  TestFile = True
End Function

Private Function FindByName(sName$) As Visio.Document
  Dim aDoc As Visio.Document
  For Each aDoc In application_.Documents
    If aDoc.FullName = sName Then
      Set FindByName = aDoc
      Exit Function
    End If
  Next aDoc
End Function

Private Function IsFileInUse(sFileName$) As Boolean
  Dim nFile%: nFile = FreeFile
  On Error Resume Next
  
  Open sFileName For Binary Access Read Lock Read Write As #nFile
  Close #nFile
  IsFileInUse = Err.Number > 0
  
  On Error GoTo 0
End Function