395 lines
10 KiB
OpenEdge ABL
395 lines
10 KiB
OpenEdge ABL
VERSION 1.0 CLASS
|
|
BEGIN
|
|
MultiUse = -1 'True
|
|
END
|
|
Attribute VB_Name = "API_WordWrapper"
|
|
Attribute VB_GlobalNameSpace = False
|
|
Attribute VB_Creatable = False
|
|
Attribute VB_PredeclaredId = False
|
|
Attribute VB_Exposed = False
|
|
' ================ Êëàññ-îáîëî÷êà äëÿ äîêóìåíòà MS Word =========================
|
|
' Shared module version: 20220410
|
|
' Tested in: TestCommons
|
|
' Depends on:
|
|
' Required reference: Scripting, Word
|
|
Option Explicit
|
|
|
|
Private Declare PtrSafe Function GetWindowThreadProcessId Lib "user32" (ByVal nHwnd As Long, nProcID As Long) As Long
|
|
|
|
Private application_ As Word.Application
|
|
Private document_ As Word.Document
|
|
Private reporter_ As Object
|
|
Private bSilent_ As Boolean
|
|
|
|
Private isPaused_ As Boolean
|
|
Private screenUpdate_ As Boolean
|
|
Private proofing_ 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
|
|
|
|
screenUpdate_ = True
|
|
proofing_ = True
|
|
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 Word.Document
|
|
Set Document = document_
|
|
End Property
|
|
|
|
Public Property Get Application() As Word.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 Word.Application
|
|
Call ResetDocument
|
|
Set application_ = CreateObject("Word.Application")
|
|
bOwnsApp_ = True
|
|
application_.Visible = bIsVisible
|
|
Set CreateApplication = application_
|
|
End Function
|
|
|
|
Public Function SetApplication(target As Word.Application)
|
|
If ObjPtr(application_) = ObjPtr(target) Then _
|
|
Exit Function
|
|
Call ResetDocument
|
|
Set application_ = target
|
|
End Function
|
|
|
|
Public Function SetDocument(target As Word.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
|
|
screenUpdate_ = application_.ScreenUpdating
|
|
proofing_ = document_.Range.NoProofing
|
|
application_.ScreenUpdating = False
|
|
document_.Range.NoProofing = True
|
|
End Function
|
|
|
|
Public Function ResumeUI()
|
|
If application_ Is Nothing Then _
|
|
Exit Function
|
|
If document_ Is Nothing Then _
|
|
Exit Function
|
|
|
|
isPaused_ = False
|
|
application_.ScreenUpdating = screenUpdate_
|
|
document_.Range.NoProofing = proofing_
|
|
Call application_.ScreenRefresh
|
|
End Function
|
|
|
|
Public Function Run(sCommand$, ParamArray vArgs() As Variant) As Variant
|
|
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 Word.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("Íå óäàëîñü ñîçäàòü äîêóìåíò èç øàáëîíà " & 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("Íå óäàëîñü ñîçäàòü íîâûé äîêóìåíò èç áàçîâîãî øàáëîíà")
|
|
If bCloseOnFail_ Then _
|
|
Call ReleaseApplication
|
|
End Function
|
|
|
|
Public Function OpenDocument(sFile$, _
|
|
Optional bReadOnly As Boolean = False, _
|
|
Optional bTrackMRU As Boolean = False) As Word.Document
|
|
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) Then
|
|
Set OpenDocument = document_
|
|
Exit Function
|
|
End If
|
|
|
|
If Not TestFile(sFile, bReadOnly) Then _
|
|
GoTo SAFE_EXIT
|
|
|
|
On Error GoTo SAFE_EXIT
|
|
Set document_ = application_.Documents.Open(sFile, AddToRecentFiles:=bTrackMRU, ReadOnly:=bReadOnly)
|
|
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_.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
|
|
|
|
Dim fso As New Scripting.FileSystemObject
|
|
Dim nFormat As WdSaveFormat
|
|
If GetSaveFormat(fso.GetExtensionName(sTargetName), nFormat) Then
|
|
Call document_.SaveAs2(sTargetName, FileFormat:=nFormat)
|
|
Else
|
|
Call document_.SaveAs2(sTargetName)
|
|
End If
|
|
|
|
On Error GoTo 0
|
|
|
|
SaveAs = True
|
|
Exit Function
|
|
RETURN_FALSE:
|
|
End Function
|
|
|
|
' =======
|
|
Private Function Report(sMsg$)
|
|
If bSilent_ Then
|
|
Debug.Print "WordWrapper: " & 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(, "Word.Application")
|
|
On Error GoTo 0
|
|
Exit Function
|
|
|
|
CREATE_NEW_APPL:
|
|
Set application_ = CreateObject("Word.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&
|
|
Call application_.Documents.Add ' Create new document for ActiveWindow to become available
|
|
nThreadID = GetWindowThreadProcessId(application_.ActiveWindow.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(SaveChanges:=False)
|
|
End Function
|
|
|
|
Private Function TryAlreadyOpened(sFile$, bReadOnly As Boolean) As Boolean
|
|
TryAlreadyOpened = False
|
|
|
|
Set document_ = FindByName(sFile)
|
|
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) As Boolean
|
|
Const ATTRIBUTE_READONLY = 1
|
|
TestFile = False
|
|
|
|
Dim fso As New Scripting.FileSystemObject
|
|
If Not fso.FileExists(sFile) Then
|
|
Call Report("Ôàéë íå íàéäåí: " & sFile)
|
|
Exit Function
|
|
End If
|
|
|
|
If Not bReadOnly Then
|
|
If fso.GetFile(sFile).Attributes And ATTRIBUTE_READONLY Then
|
|
Call Report("Ôàéë ReadOnly: " & sFile)
|
|
Exit Function
|
|
End If
|
|
If IsFileInUse(sFile) Then
|
|
Call Report("Ôàéë çàáëîêèðîâàí: " & sFile)
|
|
Exit Function
|
|
End If
|
|
End If
|
|
|
|
TestFile = True
|
|
End Function
|
|
|
|
Private Function FindByName(sName$) As Word.Document
|
|
Dim aDoc As Word.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
|
|
|
|
Private Function GetSaveFormat(sExtension$, ByRef nFormat As WdSaveFormat) As Boolean
|
|
GetSaveFormat = True
|
|
Select Case VBA.UCase(sExtension)
|
|
Case "DOCX": nFormat = wdFormatXMLDocument
|
|
Case "DOCM": nFormat = wdFormatXMLDocumentMacroEnabled
|
|
Case "DOTX": nFormat = wdFormatXMLTemplate
|
|
Case "DOTM": nFormat = wdFormatXMLTemplateMacroEnabled
|
|
Case "TXT": nFormat = wdFormatText
|
|
Case "PDF": nFormat = wdFormatPDF
|
|
Case Else: GetSaveFormat = False
|
|
End Select
|
|
End Function
|