Option Compare Database

'Класс для создания документов Word по существующим шаблонам,
'которые содержат в своем тексте переменные
'произвольного вида, которые будут заменены в последствии
'Объявление переменной класса Set a = new WordGenerator
'Далее имеет смысл задать следующие поля и свойства

'Мы можем вручную добавлять сколько угодно файлов шаблонов таким способом

' - такой шаблон будет найден по относительному пути
'   в подпапке \templates\ где лежит сам проект
'       .template_add "\court\иск.docx"
' - следующая форма добавления шаблонов в список определяет абсолютный путь
'       .template_add "C:\court\претензия.docx"
' - template_clear - очистит список шаблонов, а templates_count напомнит вам их количество
      
' - Свойство dialog = Boolean, говорит стоит ли спрашивать пользователя
'   самому указать один или несколько файлов в диалоговом окне, по умолчанию стоит
' - Близкое по смыслу булик multiselect решает разрешается ли пользователю
'   в диалоговом окне выбирать один файл или несколько
'
' - closeafter укажет объекту, закрывать (true) ли вордовский файл после произведенных
'   замен шаблонных переменных или оставить редактировать пользователю (false)

' - marker дает знать какую приписку использовать к генерируемым файлам,
'   помогает отличить один пакет документов от другого, добавляется в конец имени файла,
' - SetSaveFolder типа string по смыслу рядом, указывает в какую папку сохранять, понимает
'   абсолютный и относительный путь, т.е. "С:\temp\" сохранится туда,
'   а "\hello\" сохранится в "<путь к проекту>\result\hello\", у меня часто равен marker чтобы
'   уже по имени папки понимать, что за файло туда свалилось
'
' - основной по смыслу метод pair_add(String, Variant) - метод добавляет в объект пару для замены,
'   т.е. в тексте шаблонов будет искаться String и заменяться на Variant, в случае если Variant
'   имеет Булевский тип, то будет происходить замена на "да" и "нет".
'   Добавляем нужное число пар на замену, у меня в работе, например,
'   около 50 переменных в ворде в виде [дата], 01.03.2017, [ИНН], 6382939384
' - pair_clear очистит массив замен, а pairs_count - напомнит вам их количество

'
'   Когда мы добавили все пары и указали шаблоны, либо дали команду, что юзер сам их выберет
'   можно запускать основной метод Start (например по нажатию юзером на кнопку)



Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) As Long

Private change() As String, template() As String 'массив замен и файлов шаблона, а маркер - это приписка к имени результата в серии
Private CurrentPath, SaveFolder As String
Public marker As String
Private change_count, template_count As Integer 'количество шаблонов которые мы будем использовать
Public dialog, multiselect, closeafter As Boolean 'открывать или нет диалоговое окно & разрешать ли выбирать сразу несколько файлов, закрывать ли генеренку


'нам прислали фолдер для сохранения
Public Property Let SetSaveFolder(ByVal fld As String)
    If fld = "" Then Exit Property
    If InStr(fld, ":") > 0 Then GoTo done 'наверно у нас задан полный путь, чай не олигофрены
    If InStr(fld, "\") = 1 Then fld = CurrentPath & "\result\" & fld & "\"  'если относительный путь задан со слеша и в дерево папок ушли
    If InStr(fld, "\") = 0 Then fld = CurrentPath & "\result\"  'если папок подпапок нет, то по умолчанию
    fld = Replace(fld, "\\", "\") ' избавляемся от двойный слешей если накосячили где
done:
    SaveFolder = fld
End Property

'свойство количества пар на замену
Public Property Get pairs_count()
    pairs_count = change_count
End Property

'свойство количества файлов на замену
Public Property Get templates_count()
    templates_count = template_count
End Property


'процедура добавления 1 файла шаблона в общий их массив
Public Sub template_add(ByVal template_file As String)
  On Error Resume Next
  template_count = template_count + 1
  ReDim Preserve template(1 To template_count)
  If InStr(template_file, ":") > 0 Then template(template_count) = template_file
  'тут видимо абсолютный путь
  If InStr(template_file, "\") = 1 Or InStr(template_file, "\") = 1 Then template_file = CurrentPath & "\templates\" & template_file
  'если относительный путь задан со слеша и в дерево папок ушли
  'если папок подпапок нет, значит просто файл, по умолчанию ищем в ..\templates\
  template_file = Replace(template_file, "\\", "\")
  
  template(template_count) = template_file
End Sub

'процедура очистки шаблонов
Public Sub template_clear()
    template_count = 0
    ReDim template(1 To 1)
End Sub

'добавляем пару на замену
Public Sub pair_add(ByVal first As String, ByVal second As Variant) 'функция добавляет в финальный массив пару на замену в шаблоне
  On Error Resume Next
  change_count = change_count + 1                   'наращиваем верхний индекс массива что-то все равно уже передано
  ReDim Preserve change(1 To 2, 1 To change_count) 'меняем границы массива;
  If IsNull(second) Then second = ""
  If TypeName(second) = "Boolean" Then 'если под замену булево число, переведем на русский
    Select Case second
        Case True
            second = "да"
        Case False
            second = "нет"
    End Select
  End If
  change(1, change_count) = first
  change(2, change_count) = second
End Sub

'очистим массив замен
Public Sub pair_clear()
  change_count = 0
  ReDim change(1 To 1)
End Sub


Private Function GetFileList() 'функция возвращает число выбранных файлов
    ' Requires reference to Microsoft Office 11.0 Object Library.
   Dim fDialog As Office.FileDialog
   Dim varFile As Variant
   GetFileList = 0
   ' Set up the File Dialog.
   Set fDialog = Application.FileDialog(msoFileDialogFilePicker)

   With fDialog

      ' Allow user to make multiple selections in dialog box
      .AllowMultiSelect = multiselect 'свойство обьекта
            
      'Заботимся о смысловом заголовке окна
      Select Case multiselect
        Case False
            .Title = "Выберите один шаблон"
        Case True
            .Title = "Выберите один или сразу несколько шаблонов"
      End Select
      

      ' Clear out the current filters, and add our own.
      .Filters.clear
      .Filters.Add "Word документы и шаблоны", "*.DOC; *.DOCX; *.DOT; *.DOTX"
      
      ' Show the dialog box. If the .Show method returns True, the
      ' user picked at least one file. If the .Show method returns
      ' False, the user clicked Cancel.
      If .Show = True Then
         'Loop through each file selected and add it to our list box.
         For Each varFile In .SelectedItems
            Me.template_add (varFile)
         Next
         GetFileList = template_count 'наращиваем саму функцию
      Else
         MsgBox "Файлы не выбраны"
      End If
   End With
End Function

Public Function Start() As Boolean
   
    Start = False
    If template_count = 0 Or dialog Then 'если у нас в списке вообще нет файлов, то пытаемся запросить их у юзера, если нам разрешено
      GetFileList
      If template_count = 0 Then Exit Function 'если придурок юзер так ничего и не выбрал - возвращаем фолс и все
    End If
    
    For Each dot In template() 'если файл передан просто именем, то ищем его в папке по умолчанию
       template_generate dot
    Next
    
    Start = True
      
End Function

Private Function ExtractFileName(ByVal s As String, Optional ByVal WithExt As Boolean = True) As String
    intPos = InStrRev(s, "\")
    s = Right(s, Len(s) - intPos)
    If WithExt = False Then s = Left(s, InStr(s, ".") - 1)
    ExtractFileName = s
End Function


'массив на замену формата (1 to N, 1 to 2) где 1 и 2 это слова что на что меняем
'закрыть файл после замен - фолс
'путь и имя файла шаблона после папки \templates\, если пустое - спросим у пользователя сами
'папка для сохранения, по умолчанию result, без краевых слешей


Private Sub template_generate(ByVal dot As String, Optional ByVal SaveName As String)
    Dim file As String
    Dim i As Byte
    Dim objDoc As Object

    'запускаем Word, открываем выбранный документ
        Set ObjWord = CreateObject("Word.Application")
            With ObjWord
                .Visible = True
                .Documents.Open FileName:=dot
                Set objDoc = .ActiveDocument
            End With
        
        With objDoc.Range
            For x = 1 To UBound(change, 2)
                .Find.ClearFormatting
                .Find.Replacement.ClearFormatting
                'осуществляем замену
                With .Find
                    .Text = change(1, x)
                    .Replacement.Text = change(2, x)
                    .Forward = True
                    .Wrap = wdFindContinue
                    .Format = False
                    .MatchCase = False
                    .MatchWholeWord = True
                    .MatchWildcards = False
                    .MatchSoundsLike = False
                    .MatchAllWordForms = False
                End With
                .Find.Execute Replace:=2
            Next x
            
            FName = SaveFolder & ExtractFileName(dot, False) & "_" & marker  'objDoc.Range.FName - это имя файла, который мы сохраним
            FName = Replace(FName, ".", "") 'удаляем из имени файла точки если конечно они есть
            FName = Replace(FName, """", "") 'и кавычки, если затесались
            FName = Replace(FName, "\\", "\")
        
            MakeSureDirectoryPathExists (FName) 'мы там в функции передавали папку либо используем по умолчанию
            
            objDoc.SaveAs FileName:=FName   'сохранили файл ворда
                
            If closeafter Then 'если пользователю документ не надо продолжать редактировать то просто закрываем его
              objDoc.Close  'сам файл
              ObjWord.Quit 'и покидаем обьект ворда
            End If
        End With
        
        Set objDoc = Nothing    'освобождаем память от документа
        Set ObjWord = Nothing   'освобождаем память от вордапликейшен
        
End Sub


'инициаизирующая функция, выставим значения переменных по умолчанию
Private Sub Class_Initialize()
  CurrentPath = CurrentProject.Path 'определяем текущую папку
  ReDim template(1 To 1)
  ReDim change(1 To 2, 1 To 3)
  
  multiselect = True
  ask_files = True
  
  SaveName = "result.doc" 'по умолчанию сохраняем все таким вот незамысловатым именем
  Me.SetSaveFolder = "\result\"
  
  closeafter = False 'по умолчанию файлы не закрываем сразу после создания
End Sub