VBCommons/api/API_XLWrapper.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "API_XLWrapper"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
' ================ Êëàññ-îáîëî÷êà äëÿ äîêóìåíòà MS Excel =========================
' Shared module version: 20220421
' Tested in: TestCommons
' Depends on:
' Required reference: Scripting, Excel
Option Explicit

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

Private application_ As Excel.Application
Private document_ As Excel.Workbook
Private reporter_ As Object
Private bSilent_ As Boolean

Private isPaused_ As Boolean
Private calculation_ As Excel.XlCalculation

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_.Workbooks.Count = 0 Then _
    Call ReleaseApplication
SKIP_RELEASE:
End Sub

Public Function ResetAll()
  Call ResetDocument

  calculation_ = xlCalculationAutomatic
  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 Excel.Workbook
  Set Document = document_
End Property

Public Property Get Application() As Excel.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 Excel.Application
  Call ResetDocument
  Set application_ = CreateObject("Excel.Application")
  bOwnsApp_ = True
  application_.Visible = bIsVisible
  Set CreateApplication = application_
End Function

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

Public Function SetDocument(target As Excel.Workbook, 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
  calculation_ = application_.Calculation
  application_.Calculation = xlCalculationManual
  application_.ScreenUpdating = False
  application_.EnableEvents = False
  application_.AskToUpdateLinks = False
  application_.Cursor = xlWait
End Function

Public Function ResumeUI()
  If application_ Is Nothing Then _
    Exit Function
  If document_ Is Nothing Then _
    Exit Function
    
  isPaused_ = False
  application_.Cursor = xlNormal
  application_.AskToUpdateLinks = True
  application_.EnableEvents = True
  application_.ScreenUpdating = True
  application_.Calculation = calculation_
End Function

Public Function Run(sFunction$, ParamArray vArgs() As Variant) As Variant
  Dim sCommand$: sCommand = "'" & document_.Name & "'" & "!" & sFunction
  Dim nArgCount&: nArgCount = UBound(vArgs) - LBound(vArgs) + 1
  Select Case nArgCount
  Case 0: Run = application_.Run(sCommand)
  Case 1: Run = application_.Run(sCommand, vArgs(0))
  Case 2: Run = application_.Run(sCommand, vArgs(0), vArgs(1))
  Case 3: Run = application_.Run(sCommand, vArgs(0), vArgs(1), vArgs(2))
  Case 4: Run = application_.Run(sCommand, vArgs(0), vArgs(1), vArgs(2), vArgs(3))
  Case 5: Run = application_.Run(sCommand, vArgs(0), vArgs(1), vArgs(2), vArgs(3), vArgs(4))
  Case 6: Run = application_.Run(sCommand, vArgs(0), vArgs(1), vArgs(2), vArgs(3), vArgs(4), vArgs(5))
  Case 7: Run = application_.Run(sCommand, vArgs(0), vArgs(1), vArgs(2), vArgs(3), vArgs(4), vArgs(5), vArgs(6))
  End Select
End Function

Public Function NewDocument(Optional sTemplate$ = vbNullString, _
                            Optional bDefaultIfFail As Boolean = True) As Excel.Workbook
  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_.Workbooks.Add(sTemplate)
  bOwnsDoc_ = True
  Set NewDocument = document_
  
  Exit Function
  
TRY_DEFAULT:
  If sTemplate <> vbNullString Then
    Call Report("Íå óäàëîñü ñîçäàòü äîêóìåíò èç øàáëîíà " & sTemplate)
    If Not bDefaultIfFail Then
      If bCloseOnFail_ Then _
        Call ReleaseApplication
    Else
      On Error GoTo ERR_DEFAULT
      Set document_ = application_.Workbooks.Add
      Set NewDocument = document_
    End If
    Exit Function
  End If
  
ERR_DEFAULT:
  Call Report("Íå óäàëîñü ñîçäàòü íîâûé äîêóìåíò èç áàçîâîãî øàáëîíà")
  If bCloseOnFail_ Then _
    Call ReleaseApplication
End Function

Public Function OpenDocument(sFile$, _
                              Optional bReadOnly As Boolean = False, _
                              Optional bTrackMRU As Boolean = False, _
                              Optional bIgnoreFolder As Boolean = False) As Excel.Workbook
  If Not document_ Is Nothing Then _
    Exit Function
    
  Dim bResetApplication As Boolean
  bResetApplication = application_ Is Nothing
  If bResetApplication Then _
    Call DefaultApplication
    
  If TryAlreadyOpened(sFile, bReadOnly, bIgnoreFolder) Then
    Set OpenDocument = document_
    Exit Function
  End If
  
  If Not TestFile(sFile, bReadOnly, bIgnoreFolder) Then _
    GoTo SAFE_EXIT
  
  On Error GoTo SAFE_EXIT
  If sFile Like "*.csv" Then
    Set document_ = application_.Workbooks.Open(sFile, addToMRU:=bTrackMRU, ReadOnly:=bReadOnly, Editable:=True, Format:=6, Delimiter:=",")
  Else
    Set document_ = application_.Workbooks.Open(sFile, addToMRU:=bTrackMRU, ReadOnly:=bReadOnly, Editable:=True)
  End If
  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
  Call document_.Close(SaveChanges:=(bSaveChanges And document_.Path <> vbNullString))
  On Error GoTo 0
  
  Set document_ = Nothing
  ReleaseDocument = True
  If bCloseApplication And application_.Workbooks.Count = 0 Then _
    Call ReleaseApplication
EXIT_FUNC:
End Function

Public Function SaveAs(sTargetName$) As Boolean
  SaveAs = False

  If document_ Is Nothing Then _
    Exit Function
    
  Dim bDisplayAlerts As Boolean: bDisplayAlerts = application_.DisplayAlerts
  application_.DisplayAlerts = False

  On Error GoTo RETURN_FALSE

  Dim fso As New Scripting.FileSystemObject
  Dim nFormat As Excel.XlFileFormat
  If GetSaveFormat(fso.GetExtensionName(sTargetName), nFormat) Then
    Call document_.SaveAs(sTargetName, FileFormat:=nFormat, ConflictResolution:=xlLocalSessionChanges)
  Else
    Call document_.SaveAs(sTargetName, ConflictResolution:=xlLocalSessionChanges)
  End If

  On Error GoTo 0
  
  application_.DisplayAlerts = bDisplayAlerts
  SaveAs = True
  Exit Function
  
RETURN_FALSE:
  application_.DisplayAlerts = bDisplayAlerts
End Function

' ========
Private Function Report(sMsg$)
  If bSilent_ Then
    Debug.Print "XLWrapper: " & 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(, "Excel.Application")
  On Error GoTo 0
  Exit Function
  
CREATE_NEW_APPL:
  Set application_ = CreateObject("Excel.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_.Hwnd, 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$, bReadOnly As Boolean, bIgnoreFolder As Boolean) As Boolean
  TryAlreadyOpened = False
  
  Dim fso As New Scripting.FileSystemObject
  Set document_ = FindByName(IIf(bIgnoreFolder, fso.GetFileName(sFile), sFile), bIgnoreFolder)
  If document_ Is Nothing Then _
    Exit Function
  If document_.ReadOnly And Not bReadOnly Then
    Set document_ = Nothing
    Exit Function
  End If
  
  bOwnsDoc_ = False
  TryAlreadyOpened = True
End Function

Private Function TestFile(sFile$, bReadOnly As Boolean, bIgnoreFolder As Boolean) As Boolean
  Const ATTRIBUTE_READONLY = 1
  TestFile = False
  
  Dim fso As New Scripting.FileSystemObject
  If Not bIgnoreFolder And Not fso.FileExists(sFile) Then
    Call Report("Ôàéë íå íàéäåí: " & sFile)
    Exit Function
  End If
  
  If Not bReadOnly And fso.FileExists(sFile) Then
    If fso.GetFile(sFile).Attributes And ATTRIBUTE_READONLY Then
      Call Report("Ôàéë ReadOnly: " & sFile)
      Exit Function
    End If
    If Not bIgnoreFolder Then
      If IsFileInUse(sFile) Then
        Call Report("Ôàéë çàáëîêèðîâàí: " & sFile)
        Exit Function
      End If
    End If
  End If
  
  TestFile = True
End Function

Private Function FindByName(sName$, bIgnoreFolder As Boolean) As Excel.Workbook
  Dim aBook As Excel.Workbook
  For Each aBook In application_.Workbooks
    If bIgnoreFolder And aBook.Name = sName Or _
        Not bIgnoreFolder And aBook.FullName = sName Then
      Set FindByName = aBook
      Exit Function
    End If
  Next aBook
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

Private Function GetSaveFormat(sExtension$, ByRef nFormat As Excel.XlFileFormat) As Boolean
  GetSaveFormat = True
  Select Case VBA.UCase(sExtension)
    Case "XLSX": nFormat = xlOpenXMLWorkbook
    Case "XLSM": nFormat = xlOpenXMLWorkbookMacroEnabled
    Case "XLTX": nFormat = xlOpenXMLTemplate
    Case "XLTM": nFormat = xlOpenXMLTemplateMacroEnabled
    Case "XLAM": nFormat = xlOpenXMLAddIn
    Case "TXT": nFormat = xlText
    Case "CSV": nFormat = xlCSV
    Case "PDF": nFormat = xlTypePDF
    Case Else: GetSaveFormat = False
  End Select
End Function