MALICIOUS
916
Risk Score
Malware Insights
MITRE ATT&CK
T1059.005 Visual Basic
T1105 Ingress Tool Transfer
T1087.002 Account Discovery: Local Accounts
T1566.001 Spearphishing Attachment
T1041 Exfiltration Over C2 Channel
This malicious document contains obfuscated VBA macros that leverage WScript.Shell and URLDownloadToFile to download and execute a second-stage payload from URLs associated with ExcelVBA.ru. The macros also contain logic for self-replication via email, harvesting recipients from the MAPI address book and attaching a file to outgoing messages. The presence of a decoded Excel4 macro and the use of CreateObject with a raw CLSID further indicate a complex dropper mechanism.
Heuristics 24
-
ClamAV: Doc.Dropper.Valyria-6791994-0 critical CLAMAV_DETECTIONClamAV detected this file as malware: Doc.Dropper.Valyria-6791994-0
-
Reference to URLDownloadToFile API critical SC_STR_URLDOWNLOADReference to URLDownloadToFile API
-
VBA macros detected medium 16 related findings OLE_VBA_MACROSDocument contains VBA macro code
-
Potential Shell call in VBA critical OLE_VBA_SHELLPotential Shell call in VBAMatched line in script
Shell "Cmd.exe /c echo " & Chr(7), vbHide -
WScript.Shell usage critical OLE_VBA_WSCRIPTWScript.Shell usageMatched line in script
CreateObject("wscript.shell").Run "explorer.exe /e, """ & FolderPath$ & """" -
URLDownloadToFile in VBA critical OLE_VBA_DOWNLOADURLDownloadToFile in VBAMatched line in script
Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _ -
Obfuscated VBA Shell command with URL critical OLE_VBA_OBFUSCATED_SHELL_URLVBA macro invokes Shell with command text assembled through decoder or string-manipulation functions and includes a URL. This is a high-confidence downloader/dropper pattern, stronger than Shell or URL evidence on their own.Matched line in script
Shell "Cmd.exe /c echo " & Chr(7), vbHide -
VBA ActiveX event launches decoded Excel4 macro critical OLE_VBA_ACTIVEX_XLM_STAGERVBA code attached to an auto-firing ActiveX/UserForm control event (e.g. _Layout/_Change/_Painted) decodes a string with Replace/Split/Join/StrReverse/Chr and passes the recovered formula text to ExecuteExcel4Macro. This bridges VBA event activation into XLM formula execution to call Win32 APIs / drop payloads while evading AutoOpen and Shell keyword detection — a high-confidence macro stager, not a specific Office parser CVE.Matched line in script
' Line #1534: ' FuncDefn (Sub ExecuteExcel4Macro(ByVal Settings, ByVal SetDefaultSetting)) ' Line #1535: -
Obfuscated auto-exec VBA loader critical OLE_VBA_OBFUSCATED_AUTOEXEC_LOADERAuto-exec VBA reconstructs strings with a heavy custom decoder (numeric char-array, repeated hex-string decode, or junk-token Replace removal) and feeds them to a COM-instantiation or execution sink. This obfuscated-loader shape keeps CreateObject/Shell/URL indicators out of the macro source.Matched line in script
With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") -
VBA email-worm self-replication (Outlook mass-mailer) critical OLE_VBA_EMAIL_WORM_SELF_REPLICATIONVBA macro drives Outlook to mass-mail itself: it automates Outlook.Application, programmatically creates a mail item, and spreads by harvests recipients from the MAPI address book / inbox, attaches a file to the outgoing message, sends the message programmatically. Harvesting recipients from the address book / inbox and auto-attaching the carrier to outgoing messages is the defining behavior of the Melissa / LoveLetter / W97M mass-mailer worm lineage — there is no benign document use, independent of any AV signature.Matched line in script
With OA.CreateItem(0) 'создаем новое сообщение -
CreateObject call high OLE_VBA_CREATEOBJCreateObject callMatched line in script
If WA Is Nothing Then Set WA = CreateObject("Word.Application") Else WordAlreadyOpen = True -
GetObject call high OLE_VBA_GETOBJGetObject callMatched line in script
With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") -
cmd.exe reference in VBA high OLE_VBA_CMDcmd.exe reference in VBAMatched line in script
Shell "Cmd.exe /c echo " & Chr(7), vbHide -
VBA instantiates a COM class by raw CLSID high OLE_VBA_GETOBJECT_CLSID_EVASIONVBA uses GetObject("new:{CLSID}") to instantiate a COM class by raw CLSID rather than a CreateObject ProgID — an uncommon bypass of name-based macro detection.Matched line in script
With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") -
VBA p-code auto-exec with execution tokens high OLE_VBA_PCODE_AUTOEXEC_EXECCompiled VBA/cache stream contains an auto-execution token together with shell/download/object-execution tokens. This catches p-code-only or source-extraction-failure macro documents where visible source is unavailable.
-
Workbook_Open macro low OLE_VBA_WBOPENWorkbook_Open macroMatched line in script
Private Sub Workbook_Open() -
Auto_Open macro low OLE_VBA_AUTOAuto_Open macroMatched line in script
Sub auto_open() -
Auto_Close macro low OLE_VBA_AUTOCLOSEAuto_Close macroMatched line in script
Private Sub auto_close() -
Environ() call (env variable access) low OLE_VBA_ENVIRONEnviron() call (env variable access)Matched line in script
tmp_file$ = Environ("tmp") & "\file_MainPicture_" & PROJECT_NAME$: Kill tmp_file$ -
Reference to CreateProcess API high SC_STR_CREATEPROCESSReference to CreateProcess API
-
Suspicious cmd.exe invocation with execution flag high SC_STR_CMDSuspicious cmd.exe invocation with execution flag
-
Reference to Windows Script Host high SC_STR_WSCRIPTReference to Windows Script Host
-
Suspicious extracted artifact info EXTRACTED_FILE_STATIC_TRIAGEOne or more files extracted from inside this sample matched static suspicious-content checks such as script obfuscation, encoded payload blobs, packed data, or execution/download terms.
-
Embedded URL info EMBEDDED_URLOne or more URLs were extracted from the document. The URL itself is not a detection — see the per-URL labels for which channel (macro, JS, link annotation, document body, ...) reached each URL.URL http://ExcelVBA.ru/ Referenced by macro
- http://ExcelVBA.ru/paymentsReferenced by macro
- http://ExcelVBA.ru/programmes/Referenced by macro
- http://excelvba.ru/code/translitReferenced by macro
- http://excelvba.ru/programmes/FillDocumentsReferenced by macro
- http://excelvba.ru/articles/CommandBarReferenced by macro
- http://excelvba.ru/resources/FillDocuments/Referenced by macro
- http://ExcelVBA.ru/dReferenced by macro
- http://excelvba.ru/Referenced by macro
Extracted artifacts 1
Files carved from inside the sample during analysis.
| Filename | Kind | Source | Size |
|---|---|---|---|
macros.bas |
vba-macro | oletools.olevba.extract_macros (decoded VBA source) | 1141673 bytes |
SHA-256: 00fad2c56c40cf41477d41ce75f8dbdac58f66aad12226c542381716943c355a |
|||
|
Detection
ClamAV:
No threats found
Obfuscation or payload:
likely
Carved artifact contains 8 long base64-like blob(s).
|
|||
Preview scriptFirst 1,000 lines of the extracted script
Attribute VB_Name = "ThisWB"
Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True
'---------------------------------------------------------------------------------------
' VBA Document : ThisWB
' Author : EducatedFool Date: 18.01.2013
' Professional application development for Microsoft Excel
' http://ExcelVBA.ru/ ICQ: 5836318 Skype: ExcelVBA.ru
'---------------------------------------------------------------------------------------
Public WithEvents app As Application
Attribute app.VB_VarHelpID = -1
Private Sub app_SheetBeforeDoubleClick(ByVal sh As Object, ByVal Target As Range, Cancel As Boolean)
On Error Resume Next: Err.Clear
If sh.Parent Is ThisWorkbook Then Exit Sub
If Not SETT.GetBoolean("CheckBox_DisableDoubleClickOnHeader") Then
If Target.Row = HEADER_ROW And Target.Cells.Count = 1 Then
If Len(Trim(Target)) > 0 Then
Cancel = True
If Target <> Trim(Target) Then Target = Trim(Target)
TriesCount& = 0: Code$ = "{" & Trim(Target) & "}"
Err.Clear
Do
With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
.SetText Code$
.PutInClipboard
.GetFromClipboard
res$ = .GetText
TriesCount& = TriesCount& + 1
End With
Loop While res$ <> Code$ And TriesCount& < 10
If Err = 0 And res$ = Code$ Then
Shell "Cmd.exe /c echo " & Chr(7), vbHide
Else
With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
.SetText ""
.PutInClipboard
End With
End If
End If
End If
End If
If Target.Cells.Count = 1 Then
If HasLinkToObject(Target.Cells(1)) Then
Cancel = True
CtrlShiftT
End If
End If
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Disable_HotKeys
End Sub
Private Sub Workbook_Open()
Enable_HotKeys
End Sub
Attribute VB_Name = "sh1"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True
Attribute VB_Name = "mod_Main"
'---------------------------------------------------------------------------------------
' Module : mod_Main
' Author : EducatedFool Date: 06.06.2014
' Professional application development for Microsoft Excel
' http://ExcelVBA.ru/ ICQ: 5836318 Skype: ExcelVBA.ru
'---------------------------------------------------------------------------------------
Option Explicit
Option Compare Text
Option Private Module
Sub SaveDefaultSettings() ' настройки по-умолчанию
On Error Resume Next
SETT.LoadAllSettings
SETT.AddDefaultValue "TextBox_CombineXLS_filename", "Сводный файл.xls", , True
SETT.AddDefaultValue "TextBox_SendInterval_Min", 0
SETT.AddDefaultValue "TextBox_SendInterval_Max", 0
SETT.AddDefaultValue "TextBox_HyperlinkText", "открыть файл", , True
SETT.AddDefaultValue "ComboBox_FirstRow", 1
SETT.AddDefaultValue "ComboBox_BaseColumn", 2, True
SETT.AddDefaultValue "ComboBox_TemplatesFilter_Column", 5, True
SETT.AddDefaultValue "ComboBox_LineFeed", Chr(11), , True
SETT.AddDefaultValue "TextBox_OutputMask", "{%str%} - {%filename%}.{%ext%}", , True
SETT.AddDefaultValue "TextBox_AttachCreatedFilesMask", "*", , True
SETT.AddDefaultValue "TextBox_AttachStaticFilesMask", "*", , True
SETT.AddDefaultValue "TextBox_TemplatesFolder", ThisWorkbook.Path & "\Шаблоны\", , True
SETT.AddDefaultValue "TextBox_OutputFolder", ThisWorkbook.Path & "\Документы\", , True
SETT.AddDefaultValue "TextBox_TablesFolder", ThisWorkbook.Path & "\Таблицы\", , True
SETT.AddDefaultValue "CheckBox_ShowFolderWhenDone", True
SETT.AddDefaultValue "CheckBox_TemplatesFilter_Enabled", False
SETT.AddDefaultValue "ComboBox_SendMark_Column", 10, True
SETT.AddDefaultValue "ComboBox_Multirow_GroupColumn", 1, True
End Sub
Sub CreateProgramCommandBar()
On Error Resume Next
SaveDefaultSettings
Dim AddinMenu, ExtendedMenu
Application.ScreenUpdating = False
Set AddinMenu = GetCommandBar(PROJECT_NAME, True) ' получаем ссылку на пользовательскую панель инструментов
Add_Control AddinMenu, ct_BUTTON, 593, "CreateAllDocuments", "Сформировать документы", msoButtonIconAndCaption, True ' 248
If SETT.GetBoolean("CheckBox_ShowAdditionalMenu") Then
Set ExtendedMenu = Add_Control(AddinMenu, ct_POPUP, 0, "", " Дополнительно")
Add_Control ExtendedMenu, ct_BUTTON, 385, "UpdateUDFs", "Восстановить формулы", msoButtonIconAndCaption, True ' 202
Add_Control ExtendedMenu, ct_BUTTON, 142, "CtrlShiftT", "Вставить ссылку на таблицу... (Ctrl + Shift + T)", msoButtonIconAndCaption, True
Add_Control ExtendedMenu, ct_BUTTON, 218, "CtrlShiftI", "Вставить ссылку на изображение... (Ctrl + Shift + I)", msoButtonIconAndCaption, False ' 508
Add_Control ExtendedMenu, ct_BUTTON, 0, "AddImagesFilenamesValidationList_IntoSelectedRange", _
"Вставить список имён файлов картинок в выделенный диапазон, в виде выпадающего списка", msoButtonIconAndCaption, False ' 508
Add_Control ExtendedMenu, ct_BUTTON, 0, "AddAbsentFieldCodes", "Импортировать коды полей из шаблонов в заголовок таблицы ...", msoButtonIconAndCaption, True
End If
Add_Control AddinMenu, ct_BUTTON, 548, "ShowSettingsPage", "Настройки", msoButtonIconAndCaption, True
Add_Control AddinMenu, ct_BUTTON, 487, "ShowMainForm", "О программе ...", msoButtonIconAndCaption, True
If Len(Trim(UpdatesInfo_$)) Then
Dim arr, subMenu, i&, Caption$, descr$, v, subMenu_Updates, bf&
arr = Split(UpdatesInfo_$, "&&")
Set subMenu = Add_Control(AddinMenu, ct_POPUP, 0, "", " Обновления ", , True)
Add_Control subMenu, ct_BUTTON, 1759, "ManualInstallUpdate", "Установить последнюю версию", msoButtonIconAndCaption, True ' 1759
For i = LBound(arr) To UBound(arr)
Caption$ = Split(arr(i), "==")(0)
descr$ = Split(arr(i), "==", 2)(1)
Set subMenu_Updates = Add_Control(subMenu, ct_POPUP, 4356, "", Caption$, , i = LBound(arr))
For Each v In Split(descr$, vbLf)
bf& = 0 '534
If Trim(v) Like "+*" Then bf& = 535: v = Split(Trim(v), , 2)(1)
If Trim(v) Like "-*" Then bf& = 536: v = Split(Trim(v), , 2)(1)
If Len(Trim(v)) Then Add_Control subMenu_Updates, ct_BUTTON, bf&, "", v, msoButtonIconAndCaption, False, 1 ' 231
Next v
Next i
End If
Add_Control AddinMenu, ct_BUTTON, IIf(Val(Application.Version) <= 11, 4356, 923), "ExitProgram", "Закрыть программу", msoButtonIcon, True
Set ThisWorkbook.app = Application
Application.ScreenUpdating = True
End Sub
Sub ExitProgram()
On Error Resume Next
Dim msg$: msg$ = "Вы уверены, что хотите закрыть надстройку для заполнения документов? "
If MsgBox(msg, vbQuestion + vbDefaultButton2 + vbOKCancel, "Завершение работы программы") = vbCancel Then Exit Sub
DeleteProgramCommandBar
ThisWorkbook.Close False
End Sub
Function GetFile_MainPicture() As String
' создаёт во временной папке файл, возвращает путь к созданному файлу
On Error Resume Next:
Dim F_TXT$, buf$, tmp_file$, i&, res$, ff&: Const BufLen& = 5000
F_TXT$ = F_TXT$ & "FFD8FFE000104A46494600010101012C012C0000FFDB0043000302020302020303030304030304050805050404050A070706080C0A0C0C0B0A0B0B0D0E12100D0E110E0B0B1016101113141515150C0F171816141812141514FFDB00430103040405040509050509140D0B0D1414141414141414141414141414141414141414141414141414141414141414141414141414141414141414141414141414FFC00011080030003003012200021101031101FFC400190000030101010000000000000000000000060708040905FFC40034100001030303020305060700000000000001020304050611000712213108132223324151611415717281911617245382A1A2FFC4001801000301010000000000000000000000000405060201FFC4002811000102060104000700000000000000000102110003040521314112132361323342517191E1FFDA000C03010002110311003F00EA9E82EEFDEAB06C0756CDC579512912539CC69339B4BDD3BFB3CF23FB6A6F455EA7E212BB5F37DEE1B9615AB02E155B4C59D4575516548925452D2653E472579B8C84A7D2A00E0A483A6BDA9B0BB55B774D4AE15914286FB5E8765CE6448712B1DCF9AF152867BF7F96B8F968D360AA31CAF1CDB2AC3CB618BC155092919F260D2E63C55F810D71FF007A67"
F_TXT$ = F_TXT$ & "EDB6E7DB5BB96CA2BF6AD49352A71714CA95C14DADA713EF2168500A4A8641C11D8823A10740957A641AA4528A30A83C8EBC5119A5AE3FE8A5613FB13A9AAAF7F567C20EE755EE216FCC5D06EB88E34F53494F13554A14A8EEA42547A38414AB1D7AA8F5200D6886C98C020EA191E2777B6E4977FA6C0B1EB8EDBED52228A85C75A88DA5C758E63D8464641C2943D671D4829EA0056883C226F45D5B833EEFB5AE99AC57DFB70455355E8EC0655212F254783A84FA4389E1DD27AE7E9932B57E6CFDBFB3DF4CF52EAB79572519D5420725CBA83E7D0C803B8493C703A745918CEAE4F0CFB3436576BE152E514BD70CE51A856657425D94E60A867E2940C207E5CFC4EA36C5799D7A9F513909029D27A5079536CFE391AC11CC3CAEA34514996857CC564FA1C085D6F5C4776537C287B8D01EFBBEDDBB7CBB7AE57529050C48C7F473540F4CA4FA0A8F40918EEAD1CEE2DFD44DA8A741A95420546E59B2E4A6031163321D7E44929529011C8A50080859383D00FA68DF75F6F20EEC6DCDC1695470235522A990E1192D39DDB707D52B0950FCBA866BD7EDC53A2EDCDD1715424BD26DD151B72753D653C6257633652952940057379B0559513D720633AAA9EB32E52963603C2BA79626CE4CB27E22DFB865DCBE263712B0CADC8B1ADFB069DFDC"
F_TXT$ = F_TXT$ & "94B352983F5CB6D27FEF4978551B937277426D46E5B8AA574C1B4E2B5528D1A5A1086DC92EE436F36CB684278200CE403EA03AE0EA8B776EE914C91C9EA0B956ABCF67CD764A5030CAD5D17C14E2B8B585F2F4A3A8C763AC7797856A7F888AD53EF1B96AEFDBD528713EEC9EDD2DFE42506CABD4B2A09E190A27033E950F97584956DBB5C513A55C6B1BAD253D2848012FB2FB38C64F382F98ACAB996FA444B5D1C87C8254A2E4B70DA1FCD44BD47A1DE9B9F7E1AFDB11A6B9FC3CFA9EA64D654CA5B5CF694DA94A3E6AD21C42393692067A2BEBAE8CECCEE635BB160C2AE18C69F514AD70EA54F5FBD0E63478BCD1FC14323E69524FC74ACA2DA966DA56052A9F46A84A71BA3151FB05216A506D414A121398C9E473ED082B249F4924EBCCDA0AAC7B0FC4655683104D6A877953CCF613350F026A11B01C29F33AFAD85249CF7F246AAAD76C976A9029E4A89480031660DB231F51C9C9CEA272B2B155ABEE2D201CE72E7ECF9E34303DC53DA86BC4BD9A2DFDDFB9E8EDE59837E52D35CA6908E41AACC0C1250803A9520214AC64AB2411AB9749FF00125B2351DE3A1505DA05523516E7A054533E04B96D95B441494B8DAC0EA12A041E80FBA07C73A710BE046C3BBFF9A9B7146AD427DDA63D2584BEF06D2952DA7127CB90D7AC10087123B8"
F_TXT$ = F_TXT$ & "CE4A8FC74516952E814BABCA3582C496DD693210BAABE1D2975278A94942C9EA52A4754A46388F98D26697B45BB3B26E552834482EEE1FDFAA1514D618718A7330A5385425A1495ACF14A92968A4A41C92A38CF4D1150BC33EE55CB2FEDB73DE54FB590B6D2DAA25BF1CCB91C3912417DE012951CE094B67B0C76D0DD9F2F70183454F83B043FB86556378AD5B6555A7532D4F450E216BCA030CB4AF2D208E6B23A10127DDF89EF9D25769ABCEEFCEEFDA72EDB8A98F6ED96E2E649ACF985E52F932E30D454B984A54A5A5654BC27A0477C919725B5E11B6D6852D33AA3497AEFAA0214675CF2153D448EC7CB57B24FF008A0761F21A704488C408CDC78ACB71A3B69E2869A404A103E400E8068980A3FFD9"
For i = 1 To Len(F_TXT$) / 2
buf$ = buf$ & Chr(Val("&H" & Mid(F_TXT$, 2 * i - 1, 2)))
If Len(buf$) > BufLen& Then res$ = res$ & buf$: buf$ = "": DoEvents
Next: res$ = res$ & buf$
tmp_file$ = Environ("tmp") & "\file_MainPicture_" & PROJECT_NAME$: Kill tmp_file$
ff& = FreeFile: Open tmp_file$ For Binary Access Write As #ff
Put #ff, , res$
Close #ff
If FileLen(tmp_file$) = Len(F_TXT$) / 2 Then GetFile_MainPicture = tmp_file$ Else Debug.Print FileLen(tmp_file$), Len(F_TXT$) / 2
End Function
Attribute VB_Name = "mod_Functions"
'---------------------------------------------------------------------------------------
' Module : mod_Functions
' Author : EducatedFool Date: 06.06.2014
' Professional application development for Microsoft Excel
' http://ExcelVBA.ru/ ICQ: 5836318 Skype: ExcelVBA.ru
'---------------------------------------------------------------------------------------
Option Explicit
Option Compare Text
Option Private Module
#If VBA7 Then ' Office 2010-2013
Declare PtrSafe Function SHCreateDirectoryEx Lib "shell32" Alias "SHCreateDirectoryExA" _
(ByVal hwnd As LongPtr, ByVal pszPath As String, ByVal psa As Any) As LongPtr
#Else ' Office 2003-2007
Declare Function SHCreateDirectoryEx Lib "shell32" Alias "SHCreateDirectoryExA" _
(ByVal hwnd As Long, ByVal pszPath As String, ByVal psa As Any) As Long
#End If
Sub CtrlShiftV() ' PasteFormulasForSeparateLetters
On Error Resume Next: Err.Clear
With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
.GetFromClipboard
CopyFormulas .GetText
End With
End Sub
Sub CopyFormulas(ByVal txt$)
On Error Resume Next: Err.Clear
Dim ra As Range, N&, nn&, k&, cell As Range, addr$
Application.ScreenUpdating = False
Set ra = Selection
For Each cell In ra.Cells
N = N + 1
If N = 1 Then
addr$ = cell.Address(1, 1, xlA1)
cell.Value = txt
cell.Font.Color = vbWhite
cell.Font.Size = 1
Else
If cell.Address = cell.MergeArea.Cells(1).Address Then
k = k + 1: cell.NumberFormat = "General"
cell.Formula = "=MID(" & addr & "," & k & ",1)"
End If
End If
Next cell
If Err = 0 Then Shell "Cmd.exe /c echo " & Chr(7), vbHide
Application.ScreenUpdating = True
End Sub
Sub Enable_HotKeys()
' назначает комбинации клавиш, если соответствующие опция включены в настройках программы
On Error Resume Next
With Application
If SETT.GetBoolean("CheckBox_PasteFormulasForSeparateLetters") Then .OnKey "^+v", "CtrlShiftV" Else .OnKey "^+v"
If SETT.GetBoolean("CheckBox_InsertTableLinks") Then .OnKey "^+t", "CtrlShiftT" Else .OnKey "^+t"
If SETT.GetBoolean("CheckBox_InsertImageLinks") Then .OnKey "^+i", "CtrlShiftI" Else .OnKey "^+i"
End With
End Sub
Sub Disable_HotKeys()
On Error Resume Next: Err.Clear
Application.OnKey "^+v"
End Sub
Function SpecialCells_TypeConstants(ByRef ra As Range) As Range
' возвращает диапазон, содержащий все заполненные ячейки диапазона ra
On Error Resume Next: Dim en&: en& = Err.Number
If ra.Worksheet.ProtectContents Then ' если лист защищён
Dim cell As Range
' перебираем все ячейки в диапазоне
For Each cell In Intersect(ra, ra.Worksheet.UsedRange).Cells
If Trim(cell.Value) <> "" Then ' если ячейка непустая
' то добавляем её в результат
If SpecialCells_TypeConstants Is Nothing Then
Set SpecialCells_TypeConstants = cell
Else
Set SpecialCells_TypeConstants = Union(SpecialCells_TypeConstants, cell)
End If
End If
Next cell
Else ' если защита листа не установлена - используем штатные средства Excel
Set SpecialCells_TypeConstants = ra.SpecialCells(xlCellTypeConstants)
End If
If en& = 0 Then Err.Clear
End Function
Function SpecialCells_VisibleRows(ByRef ra As Range) As Range
On Error Resume Next: Dim en&: en& = Err.Number
If ra.Worksheet.ProtectContents Then
Dim ro As Range
For Each ro In Intersect(ra, ra.Worksheet.UsedRange.EntireRow).rows
If ro.EntireRow.Hidden = False Then
If SpecialCells_VisibleRows Is Nothing Then
Set SpecialCells_VisibleRows = ro
Else
Set SpecialCells_VisibleRows = Union(SpecialCells_VisibleRows, ro)
End If
End If
Next ro
Else
Set SpecialCells_VisibleRows = ra.SpecialCells(xlCellTypeVisible)
End If
If en& = 0 Then Err.Clear
End Function
Function RenderString(ByVal txt$, ByRef options As Dictionary) As String
On Error Resume Next: Dim arr, i&: arr = options.keys
For i = LBound(arr) To UBound(arr)
txt$ = Replace(txt$, arr(i), options(arr(i)))
Next i
RenderString = txt$
End Function
Function CreatePathForFile(ByVal OldFilename$, ByRef options As Dictionary) As String
On Error Resume Next: Err.Clear
Dim mask$, ShortOldFilename$, subfolder$, filename$, pcc&, NewFolderPath$, NewFilename$
mask$ = SETT.GetText("TextBox_OutputMask") ' f.e., {str} - {filename}.{ext}
If Len(TMP_OUTPUT_MASK$) Then mask$ = TMP_OUTPUT_MASK$
ShortOldFilename$ = Replace(OldFilename$, TEMPLATES_FOLDER$, "")
subfolder$ = Left(ShortOldFilename$, InStrRev(ShortOldFilename$, "\") - 1)
If Len(subfolder$) Then subfolder$ = subfolder$ & "\"
filename$ = Dir(OldFilename$)
filename$ = Left(filename$, InStrRev(filename$, ".") - 1)
If filename$ Like "*{print=#*}*" Then
pcc& = Val(Split(filename$, "{print=")(1))
filename$ = Replace(filename$, "{print=" & pcc& & "}", "")
options("{%pcc%}") = pcc&
End If
If filename$ Like "*{pdf}*" Then
filename$ = Replace(filename$, "{pdf}", "")
options("{%pdf%}") = 1
End If
options("{%filename%}") = RenderString(filename$, options)
options("{%ext%}") = GetExtensionForNewFile(ShortOldFilename$)
NewFilename$ = OUTPUT_FOLDER$ & subfolder$ & Replace_symbols2(RenderString(mask$, options))
' создание папки для файла
NewFolderPath$ = Left(NewFilename$, InStrRev(NewFilename$, "\"))
If Len(Dir(NewFolderPath$, vbDirectory)) = 0 Then ' если папка отсутствует
SHCreateDirectoryEx Application.hwnd, NewFolderPath$, ByVal 0& ' создаём путь
End If
If Val(Application.Version) > 11 And (PRINT_TO_PDF Or (Val(options("{%pdf%}")) = 1)) Then ' вывод в ПДФ
If TemplateType(OldFilename$) <> "TXT" Then
NewFilename$ = Left(NewFilename$, InStrRev(NewFilename$, ".") - 1) & ".pdf"
End If
End If
CreatePathForFile = NewFilename$
End Function
Function GetExtensionForNewFile(ByVal filename$)
On Error Resume Next: Err.Clear
Select Case Extension(filename$)
Case "XLT": GetExtensionForNewFile = "XLS"
Case "XLTM": GetExtensionForNewFile = "XLSM"
Case "XLTX": GetExtensionForNewFile = "XLSX"
Case "DOT": GetExtensionForNewFile = "DOC"
Case "DOTM": GetExtensionForNewFile = "DOCM"
Case "DOTX": GetExtensionForNewFile = "DOCX"
Case "DOCXML": GetExtensionForNewFile = "XML"
Case Else: GetExtensionForNewFile = Extension(filename$)
End Select
End Function
Function GetFileFormatForNewFile(ByVal filename$) As Long
On Error Resume Next: Err.Clear
Select Case Extension(filename$)
Case "CSV": GetFileFormatForNewFile = xlCSV
Case "XLS": GetFileFormatForNewFile = xlWorkbookNormal
Case "XLSM": GetFileFormatForNewFile = 52 ' xlOpenXMLWorkbookMacroEnabled
Case "XLSX": GetFileFormatForNewFile = 51 ' xlOpenXMLWorkbook
Case "DOC": GetFileFormatForNewFile = 0 ' wdFormatDocument
Case "DOCM": GetFileFormatForNewFile = 13 ' wdFormatXMLDocumentMacroEnabled
Case "DOCX": GetFileFormatForNewFile = 12 ' wdFormatXMLDocument
Case "XML": GetFileFormatForNewFile = 19 ' wdFormatFlatXML (XML)
' Case "XML": GetFileFormatForNewFile = 11 ' wdFormatXML (XML 2003)
End Select
End Function
Function ReadOptions(ByRef ro As Range) As Dictionary
' возвращает коллекцию значений для подстановки
Set ReadOptions = New Dictionary
Dim cell As Range, i&, KeysRange As Range, key$, baseKey$, newkey$, txt$, LenStep&, wbname$, txt_part$
On Error Resume Next
Set KeysRange = SpecialCells_TypeConstants(ro.Worksheet.rows(HEADER_ROW))
For Each cell In KeysRange.Cells
key$ = Trim(cell)
If Len(key$) > 250 Then key$ = Left(key$, 250)
If Not key$ Like "*}" Then key$ = key$ & "}"
If Not key$ Like "{*" Then key$ = "{" & key$
txt$ = Intersect(ro.EntireRow, cell.EntireColumn).Text
If cell.EntireColumn.Hidden Then txt$ = Intersect(ro.EntireRow, cell.EntireColumn).Value
If Len(txt$) < 152 Then ' ограничение длины заменяемой строки - 255 символов
ReadOptions.Add key$, txt$
Else
LenStep& = 250 - Len(key$) - 12 ' немного индийского кода:) но работает!
baseKey$ = key$
For i = 1 To Len(txt$) Step LenStep&
txt_part$ = Mid(txt$, i, LenStep&)
newkey$ = baseKey$ & "{l=" & i & "}"
If i + LenStep& - 1 < Len(txt$) Then txt_part$ = txt_part$ & newkey$
ReadOptions.Add key$, txt_part$
key$ = newkey$
Next i
End If
Next cell
AddNamedRangesIntoDictionary ReadOptions, ro.Worksheet.Parent
ReadOptions.Add "{%str%}", ro.Row
ReadOptions.Add "{%date%}", Format(Now, "YYYY-MM-DD")
ReadOptions.Add "{%shortdate%}", Format(Now, "YYMMDD")
ReadOptions.Add "{%longdate%}", Format(Now, "DD MMMM YYYY")
ReadOptions.Add "{%time%}", Format(Now, "HH-NN-SS")
ReadOptions.Add "{%shorttime%}", Format(Now, "HHNNSS")
ReadOptions.Add "{%datetime%}", Format(Now, "YYYY-MM-DD HH-NN-SS")
ReadOptions.Add "{%shortdatetime%}", Format(Now, "YYMMDD-HHNNSS")
ReadOptions.Add "{%longdatetime%}", Format(Now, "DD MMMM YYYY HH-NN-SS")
ReadOptions.Add "{%sheet_name%}", ro.Worksheet.Name
ReadOptions.Add "{%sheet_index%}", ro.Worksheet.index
wbname$ = ro.Worksheet.Parent.Name: If wbname$ Like "*.*" Then wbname$ = Left(wbname$, InStrRev(wbname$, ".") - 1)
ReadOptions.Add "{%workbook_name%}", wbname$
End Function
Sub AddNamedRangesIntoDictionary(ByRef dict As Dictionary, ByRef WB As Workbook)
On Error Resume Next
Dim PrintCopies_FieldName$, N As Name, cell As Range
' ==================================
PrintCopies_FieldName$ = Trim(SETT.GetText("TextBox_PrintCopies_FieldName", ""))
If Not PrintCopies_FieldName$ Like String(Len(PrintCopies_FieldName$), "#") Then
If Not PrintCopies_FieldName$ Like "*}" Then PrintCopies_FieldName$ = PrintCopies_FieldName$ & "}"
If Not PrintCopies_FieldName$ Like "{*" Then PrintCopies_FieldName$ = "{" & PrintCopies_FieldName$
End If
If Len(PrintCopies_FieldName$) > 2 Or Val(PrintCopies_FieldName$) > 0 Then
dict.Add "{%PrintCopiesCount%}", PrintCopies_FieldName$
End If
' ==================================
Dim i&, key$, baseKey$, newkey$, txt$, txt_part$, LenStep&, arr
For Each N In WB.Names
Set cell = Nothing: Set cell = N.RefersToRange.Cells(1)
If Not cell Is Nothing Then
key$ = "{=" & N.Name & "}"
txt$ = cell.Text
If Len(txt$) < 152 Then ' ограничение длины заменяемой строки - 255 символов
dict.Add key$, txt$
Else
LenStep& = 250 - Len(key$) - 12 ' немного индийского кода:) но работает!
baseKey$ = key$
For i = 1 To Len(txt$) Step LenStep&
txt_part$ = Mid(txt$, i, LenStep&)
newkey$ = baseKey$ & "{l=" & i & "}"
If i + LenStep& - 1 < Len(txt$) Then txt_part$ = txt_part$ & newkey$
dict.Add key$, txt_part$
key$ = newkey$
Next i
End If
' --------------
key$ = "{=" & cell.Address(0, 0) & "}"
txt$ = WB.ActiveSheet.Range(cell.Address).Text
If Len(txt$) < 152 Then ' ограничение длины заменяемой строки - 255 символов
dict.Add key$, txt$
Else
LenStep& = 250 - Len(key$) - 12 ' немного индийского кода:) но работает!
baseKey$ = key$
For i = 1 To Len(txt$) Step LenStep&
txt_part$ = Mid(txt$, i, LenStep&)
newkey$ = baseKey$ & "{l=" & i & "}"
If i + LenStep& - 1 < Len(txt$) Then txt_part$ = txt_part$ & newkey$
dict.Add key$, txt_part$
key$ = newkey$
Next i
End If
End If
Next
' заменяем коды символов на сами символы
arr = dict.keys
For i = LBound(arr) To UBound(arr)
key$ = arr(i)
txt$ = "": txt$ = dict(key$)
If txt$ Like "*{chr#*}*" Then
txt = Replace(txt, "{chr10}", Chr(10))
txt = Replace(txt, "{chr11}", Chr(11))
txt = Replace(txt, "{chr13}", Chr(13))
txt = Replace(txt, "{chr1310}", vbNewLine)
dict(key$) = txt$
End If
Next i
End Sub
Function ReadMultirowOptions(ByRef ra As Range) As Dictionary
' возвращает коллекцию значений для подстановки
Set ReadMultirowOptions = New Dictionary
Dim ro As Range, cell As Range, KeysRange As Range, key$, key2$, txt$, rn&, wbname$, str_txt$
Dim i&, txt_part$, baseKey$, baseKey2$, newkey$, newkey2$, LenStep&, txt_part1$, txt_part2$
On Error Resume Next
Set KeysRange = SpecialCells_TypeConstants(ra.Worksheet.rows(HEADER_ROW))
For Each ro In ra.rows ' перебираем все выделенные строки
rn = rn + 1
For Each cell In KeysRange.Cells
key$ = Trim(cell)
If Len(key$) > 250 Then key$ = Left(key$, 250)
If Not key$ Like "*}" Then key$ = key$ & "}"
If Not key$ Like "{*" Then key$ = "{" & key$
key2$ = Left(key$, Len(key$) - 1) & "#" & rn & "}"
txt$ = Intersect(ro.EntireRow, cell.EntireColumn).Text
If cell.EntireColumn.Hidden Then txt$ = Intersect(ro.EntireRow, cell.EntireColumn).Value
If Len(txt$) < 152 Then ' ограничение длины заменяемой строки - 255 символов
If rn = 1 Then ReadMultirowOptions.Add key$, txt$
ReadMultirowOptions.Add key2$, txt$
Else
LenStep& = 250 - Len(key$) - 12 ' немного индийского кода:) но работает!
baseKey$ = key$
baseKey2$ = key2$
For i = 1 To Len(txt$) Step LenStep&
txt_part$ = Mid(txt$, i, LenStep&)
newkey$ = baseKey$ & "{l=" & i & "}"
newkey2$ = baseKey2$ & "{l=" & i & "}"
txt_part1$ = txt_part$: If i + LenStep& - 1 < Len(txt$) Then txt_part1$ = txt_part$ & newkey$
txt_part2$ = txt_part$: If i + LenStep& - 1 < Len(txt$) Then txt_part2$ = txt_part$ & newkey2$
If rn = 1 Then ReadMultirowOptions.Add key$, txt_part1$
ReadMultirowOptions.Add key2$, txt_part2$
key$ = newkey$
key2$ = newkey2$
Next i
End If
Next cell
str_txt$ = str_txt$ & "," & ro.Row
Next ro
' Set dic = ReadMultirowOptions
' For Each k In dic.Keys
' Debug.Print k, dic(k)
' Next
AddNamedRangesIntoDictionary ReadMultirowOptions, ra.Worksheet.Parent
ReadMultirowOptions.Add "{%str%}", Mid(str_txt$, 2)
ReadMultirowOptions.Add "{%rc%}", rn
ReadMultirowOptions.Add "{%date%}", Format(Now, "YYYY-MM-DD")
ReadMultirowOptions.Add "{%shortdate%}", Format(Now, "YYMMDD")
ReadMultirowOptions.Add "{%longdate%}", Format(Now, "DD MMMM YYYY")
ReadMultirowOptions.Add "{%time%}", Format(Now, "HH-NN-SS")
ReadMultirowOptions.Add "{%shorttime%}", Format(Now, "HHNNSS")
ReadMultirowOptions.Add "{%datetime%}", Format(Now, "YYYY-MM-DD HH-NN-SS")
ReadMultirowOptions.Add "{%shortdatetime%}", Format(Now, "YYMMDD-HHNNSS")
ReadMultirowOptions.Add "{%longdatetime%}", Format(Now, "DD MMMM YYYY HH-NN-SS")
ReadMultirowOptions.Add "{%sheet_name%}", ro.Worksheet.Name
ReadMultirowOptions.Add "{%sheet_index%}", ro.Worksheet.index
wbname$ = ra.Worksheet.Parent.Name: If wbname$ Like "*.*" Then wbname$ = Left(wbname$, InStrRev(wbname$, ".") - 1)
ReadMultirowOptions.Add "{%workbook_name%}", wbname$
End Function
Function CollectionOfRowsBlocks(ByRef ra As Range) As Collection
' получает диапазон строк ra, ищет в столбце ComboBox_Multirow_GroupColumn уникальные значения,
' разбивает диапазон на блоки строк, по каждому из уникальных значений
On Error Resume Next: Err.Clear
Set CollectionOfRowsBlocks = New Collection
Dim cell As Range, coll As New Collection, txt$, block As Range, col&, msg$, v
If SETT.GetBoolean("CheckBox_Multirow_GroupRows") Then
col& = SETT.GetNumber("ComboBox_Multirow_GroupColumn")
If col& = 0 Then
msg$ = "В настройках программы включен режим «MiltiRow» с опцией" & vbNewLine & _
"«Группировать строки по заданному столбцу»" & vbNewLine & vbNewLine & _
"А номер столбца, по которому надо группировать строки, — не указан." & vbNewLine & vbNewLine & _
"Измените настройки программы, и снова запустите формирование документов."
MsgBox msg, vbExclamation, "Не задан столбец, по которому группировать строки"
ShowSettingsPage
F_Settings.MultiPage_Options.Value = 4
F_Settings.ComboBox_Multirow_GroupColumn.SetFocus
F_Settings.ComboBox_Multirow_GroupColumn.BackColor = vbRed
Exit Function
End If
For Each cell In Intersect(ra.EntireRow, ra.Worksheet.Columns(col&)).Cells
txt$ = Trim(cell): If Len(txt$) Then coll.Add txt$, txt$
Next cell
If coll.Count = 0 Then
msg$ = "В настройках программы включен режим «MiltiRow» с опцией" & vbNewLine & _
"«Группировать строки по заданному столбцу»" & vbNewLine & vbNewLine & _
"Указан номер столбца, по которому надо группировать строки: «" & col& & "»" & vbNewLine & vbNewLine & _
"В этом столбце, в выбранных строках, программа не нашла ни одной заполненной ячейки." & vbNewLine & _
"Измените настройки программы, и снова запустите формирование документов."
MsgBox msg, vbExclamation, "Не задан столбец, по которому группировать строки"
ShowSettingsPage
F_Settings.MultiPage_Options.Value = 4
F_Settings.ComboBox_Multirow_GroupColumn.SetFocus
F_Settings.ComboBox_Multirow_GroupColumn.BackColor = vbRed
Exit Function
End If
For Each v In coll
Set block = Nothing
For Each cell In Intersect(ra.EntireRow, ra.Worksheet.Columns(col&)).Cells
If Trim(cell) = v Then
If block Is Nothing Then Set block = cell Else Set block = Union(block, cell)
End If
Next cell
If block Is Nothing Then
MsgBox "Ошибка группировки строк в режиме Multirow", vbCritical, "Обратитесь к разработчику программы"
Exit Function
Else
CollectionOfRowsBlocks.Add block.EntireRow
End If
Next v
Else ' возвращаем один блок - со всеми строками
CollectionOfRowsBlocks.Add ra
End If
End Function
Function CreateAndFill_XLS(ByVal TemplateFilename$, ByVal NewFilename$, _
ByRef options As Dictionary, Optional ByRef pi As ProgressIndicator) As Boolean
On Error Resume Next: Err.Clear
Dim WB As Workbook, sh As Worksheet, nam As Name, ra As Range, calc As XlCalculation, i&, txt_Line2$
pi.Line3 = "Файл: " & Dir(TemplateFilename$, vbNormal)
calc = Application.Calculation
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
If TemplateType(TemplateFilename$) Like "*template*" Then
pi.Line2 = "Создание документа Excel по шаблону ..."
Set WB = Application.Workbooks.Add(TemplateFilename$)
Else
pi.Line2 = "Открытие исходного документа Excel ..."
Set WB = Application.Workbooks.Open(TemplateFilename$, False, True)
End If
' Main_PI.Log "Документ создан? " & Not (WB Is Nothing)
If SETT.GetBoolean("CheckBox_MultiRow") Then ' размножение специальных строк в шаблоне
Dim rc&: rc = Val(options("{%rc%}"))
If rc& = 0 Then Main_PI.Log vbTab & "Ошибка при подготовке документа Excel: rc& = 0": Exit Function
pi.Line2 = "Добавление строк (" & rc& & " шт.) - режим MULTIROW ..."
For Each nam In WB.Names
If nam.Name Like "MultiRow*" Then
Set ra = Nothing: Set ra = nam.RefersToRange.EntireRow
If Not ra Is Nothing Then
For i = 1 To rc&
ra.Offset(i).Insert Shift:=xlDown
ra.Copy ra.Offset(i)
ra.Offset(i).Replace "#}", "#" & i & "}", xlPart
ra.Offset(i).Replace "{%index%}", i, xlPart
Next i
ra.EntireRow.Delete
End If
End If
Next
End If
txt_Line2$ = "Подстановка значений в созданный по шаблону документ ..."
pi.Line2 = txt_Line2$
Dim RIC As Boolean, arr, key$, txt$, File_Format
arr = options.keys
RIC = SETT.GetBoolean("CheckBox_ReplaceInColon")
For i = LBound(arr) To UBound(arr)
key$ = arr(i)
txt$ = options(arr(i))
For Each sh In WB.Worksheets
sh.UsedRange.Replace key$, txt$, xlPart, , False
If RIC Then
With sh.PageSetup
.LeftFooter = Replace(.LeftFooter, key$, txt$, , , vbTextCompare)
.LeftHeader = Replace(.LeftHeader, key$, txt$, , , vbTextCompare)
.CenterFooter = Replace(.CenterFooter, key$, txt$, , , vbTextCompare)
.CenterHeader = Replace(.CenterHeader, key$, txt$, , , vbTextCompare)
.RightFooter = Replace(.RightFooter, key$, txt$, , , vbTextCompare)
.RightHeader = Replace(.RightHeader, key$, txt$, , , vbTextCompare)
End With
End If
Next sh
If i Mod IIf(RIC, 5, 30) = 0 Then
pi.Line2 = txt_Line2$ & " (выполнено " & Format(i / UBound(arr), "0%") & ")"
End If
DoEvents
Next i
pi.Line2 = "Вычисление (пересчёт) формул ..."
For Each sh In WB.Worksheets
sh.Calculate
If SETT.GetBoolean("CheckBox_FormulasToValues") Then sh.UsedRange.Value = sh.UsedRange.Value
Next sh
Application.Run "'" & WB.Name & "'!FillDone"
pi.Line2 = "Сохранение заполненного документа ..."
pi.Line3 = "Новое имя файла: " & Split(NewFilename$, "\")(UBound(Split(NewFilename$, "\")))
Main_PI.Log vbTab & "Сохранение созданного файла: " & Replace(NewFilename$, OUTPUT_FOLDER$, "...\")
pi.FP.Repaint
If Val(Application.Version) > 11 And (PRINT_TO_PDF Or (Val(options("{%pdf%}")) = 1)) Then ' вывод в ПДФ
WB.ExportAsFixedFormat 0, NewFilename$ ' xlTypePDF = 0
Else ' обычное сохранение файла Excel
File_Format = GetFileFormatForNewFile(NewFilename$)
If Len(File_Format) Then
WB.SaveAs NewFilename$, Val(File_Format)
Else
WB.SaveAs NewFilename$
End If
End If
If SETT.GetBoolean("CheckBox_ImmediatePrintOut") Then WB.PrintOut , , PrintCopiesCount(options)
WB.Close False
CreateAndFill_XLS = Err = 0
Application.Calculation = calc
Application.DisplayAlerts = True
End Function
Function PrintCopiesCount(ByRef options As Dictionary) As Long
On Error Resume Next
Dim en&, PrintCopiesField$, CopiesCount&, pcc As Variant
en& = Err.Number
PrintCopiesCount = 1
PrintCopiesField$ = options("{%PrintCopiesCount%}")
If PrintCopiesField$ Like "{*?}" Then
CopiesCount& = Fix(Val(options(PrintCopiesField$)))
Else
CopiesCount& = Fix(Val(PrintCopiesField$))
End If
If CopiesCount& > 0 Then PrintCopiesCount = CopiesCount&
pcc = options("{%pcc%}")
If pcc <> "" Then PrintCopiesCount = Val(pcc)
If en& = 0 Then Err.Clear ' Debug.Print "PrintCopiesCount = " & PrintCopiesCount
End Function
Function CreateAndFill_DOC(ByVal TemplateFilename$, ByVal NewFilename$, _
ByRef options As Dictionary, Optional ByRef pi As ProgressIndicator) As Boolean
On Error Resume Next: Err.Clear
Dim doc As Object, ecount As Long, bm As Object, myStoryRange As Object, i&, oFirstCellRange As Object, bmText$
pi.Line3 = "Файл: " & Dir(TemplateFilename$, vbNormal)
If TemplateType(TemplateFilename$) Like "*template*" Then
pi.Line2 = "Создание документа Word по шаблону ..."
Set doc = WA.Documents.Add(TemplateFilename$)
Else
pi.Line2 = "Открытие исходного документа Word ..."
Set doc = WA.Documents.Open(TemplateFilename$, , False, False)
End If
' Main_PI.Log "Документ создан? " & Not (doc Is Nothing)
doc.ActiveWindow.View.ShowFieldCodes = True ' отображаем поля
If SETT.GetBoolean("CheckBox_MultiRow") Then ' размножение специальных строк в шаблоне
Dim rc&: rc = Val(options("{%rc%}"))
If rc& = 0 Then Main_PI.Log vbTab & "Ошибка при подготовке документа Word: rc& = 0": Exit Function
' Dim bm As Bookmark, ra As word.Range, oFirstCellRange As word.Range
For Each bm In doc.Bookmarks
If bm.Name Like "MultiRow*" Then
If bm.Range.Information(12) Then 'Закладка в таблице
For i = 1 To rc&
With bm.Range
Set oFirstCellRange = .Cells(1).Range
oFirstCellRange.Collapse 1 'wdCollapseStart
.Copy
'Вставка строки из закладки над закладкой
oFirstCellRange.PasteAndFormat 16 'wdFormatOriginalFormatting
WordReplacements .Tables(1).rows(.rows(1).index).Range, "#}", "#" & i & "}"
WordReplacements .Tables(1).rows(.rows(1).index).Range, "{%index%}", i
End With
Next
bm.Range.rows(1).Delete
Else
bmText$ = bm.Range.Text
For i = rc& To 1 Step -1
With bm.Range
.InsertParagraphAfter
With .Paragraphs.First.Next
.Range.InsertCrossReference ReferenceType:=2, ReferenceKind:=-1, _
ReferenceItem:=bm.Name, InsertAsHyperlink:=False, _
IncludePosition:=False, SeparateNumbers:=False, SeparatorString:=" "
.Range.Fields.Unlink
End With
WordReplacements .Paragraphs.First.Next.Range, "#}", "#" & i & "}"
WordReplacements .Paragraphs.First.Next.Range, "{%index%}", i
End With
Next
bm.Range.Delete
End If
DoEvents
End If
Next
End If
pi.Line2 = "Подстановка значений в созданный по шаблону документ ..."
Dim arr, FullReplace As Boolean, Replace_LF_with$, key$, txt$, File_Format As Long
arr = options.keys
Replace_LF_with$ = Replace(SETT.GetText("ComboBox_LineFeed"), "del", "")
FullReplace = SETT.GetBoolean("CheckBox_ReplaceInColon")
For i = LBound(arr) To UBound(arr)
key$ = arr(i)
txt$ = options(arr(i))
txt$ = Replace(txt$, Chr(10), Replace_LF_with$) ' переносы строк
Err.Clear
If HasLinkToObject(txt$, key$) Then
InsertObjectIntoDOC doc, txt$, key$, pi
Err.Clear
Else
If FullReplace Then
' новая версия замены
For Each myStoryRange In doc.StoryRanges
DoEvents
myStoryRange.Find.Execute key$, False, , False, , , , , , txt$, 2
While Not (myStoryRange.NextStoryRange Is Nothing)
Set myStoryRange = myStoryRange.NextStoryRange
myStoryRange.Find.Execute key$, False, , False, , , , , , txt$, 2
Wend
Next myStoryRange
Else
' обычная быстрая замена
doc.Range.Find.Execute key$, False, , False, , , , , , txt$, 2
End If
End If
If Err Then
ecount = ecount + 1
pi.Parent.Log "ОШИБКА " & Err.Number & " при подстановке данных в поле " & key$ & ": " & Err.Description
End If
Next i
doc.ActiveWindow.View.ShowFieldCodes = False ' скрываем поля
pi.Line2 = "Сохранение заполненного документа ..."
pi.Line3 = "Новое имя файла: " & Split(NewFilename$, "\")(UBound(Split(NewFilename$, "\")))
Main_PI.Log vbTab & "Сохранение созданного файла: " & Replace(NewFilename$, OUTPUT_FOLDER$, "...\")
pi.FP.Repaint
If Val(Application.Version) > 11 And (PRINT_TO_PDF Or (Val(options("{%pdf%}")) = 1)) Then ' вывод в ПДФ
doc.ExportAsFixedFormat NewFilename$, 17
Else ' обычное сохранение файла Word
File_Format = GetFileFormatForNewFile(NewFilename$)
'Debug.Print File_Format
If Len(File_Format) Then
doc.SaveAs NewFilename$, Val(File_Format)
Else
doc.SaveAs NewFilename$
End If
End If
If IMMEDIATE_PRINTOUT Then doc.PrintOut Copies:=PrintCopiesCount(options)
doc.Close False
CreateAndFill_DOC = (Err = 0 And ecount = 0)
End Function
Sub WordReplacements(rng As Object, ByVal FindText As String, ByVal ReplaceText As String)
rng.Find.Execute FindText:=FindText, ReplaceWith:=ReplaceText, Replace:=2
End Sub
Function CreateAndFill_TXT(ByVal TemplateFilename$, ByVal NewFilename$, _
ByRef options As Dictionary, Optional ByRef pi As ProgressIndicator) As Boolean
On Error Resume Next: Err.Clear
Dim TextFile$, arr, i&, key$, txt$
pi.Line3 = "Файл: " & Dir(TemplateFilename$, vbNormal)
pi.Line2 = "Чтение текстового документа ..."
TextFile$ = ReadTXTfile(TemplateFilename$)
pi.Line2 = "Подстановка значений в текстовый файл ..."
arr = options.keys
For i = LBound(arr) To UBound(arr)
key$ = arr(i)
txt$ = options(arr(i))
TextFile$ = Replace(TextFile$, key$, txt$, , , vbTextCompare)
Next i
pi.Line2 = "Сохранение заполненного документа ..."
pi.Line3 = "Новое имя файла: " & Split(NewFilename$, "\")(UBound(Split(NewFilename$, "\")))
Main_PI.Log vbTab & "Сохранение созданного файла: " & Replace(NewFilename$, OUTPUT_FOLDER$, "...\")
pi.FP.Repaint
SaveTXTfile NewFilename$, TextFile$
CreateAndFill_TXT = Err = 0
End Function
Function TemplateType(ByVal filename$) As String
Select Case Extension(filename$)
Case "XLS", "XLSM", "XLSX", "XLSB", "CSV": TemplateType = "XLS"
Case "XLT", "XLTM", "XLTX": TemplateType = "XLS-template"
Case "DOC", "DOCM", "DOCX", "DOCB", "DOCXML": TemplateType = "DOC"
Case "DOT", "DOTM", "DOTX": TemplateType = "DOC-template"
Case "TXT", "DAT", "XML": TemplateType = "TXT"
End Select
End Function
Function TemplateTypeForListbox(ByVal filename$) As String
Select Case Extension(filename$)
Case "XLS", "XLSM", "XLSX", "XLSB", "CSV": TemplateTypeForListbox = "Excel"
Case "XLT", "XLTM", "XLTX": TemplateTypeForListbox = "Excel"
Case "DOC", "DOCM", "DOCX", "DOCB", "DOCXML": TemplateTypeForListbox = "Word"
Case "DOT", "DOTM", "DOTX": TemplateTypeForListbox = "Word"
Case "TXT", "DAT", "XML": TemplateTypeForListbox = "Text"
Case Else: TemplateTypeForListbox = "?"
End Select
End Function
Function CheckTemplateFiles(ByRef coll As Collection) As Boolean
On Error Resume Next
Dim msg$, i&, filename$, ttype$, N&, ttl$
If coll.Count = 0 And Not SEND_MAIL_MODE Then
msg$ = "В папке с шаблонами документов не найдено ни одного файла. " & _
vbNewLine & "Убедитесь, что вы верно задали папку, содержащую шаблоны документов." & vbNewLine & vbNewLine & _
"Путь к папке с шаблонами (задан в настройках программы):" & vbNewLine & TEMPLATES_FOLDER$
MsgBox msg, vbCritical, "Не найдены файлы шаблонов"
Debug.Print "Шаблоны не найдены"
ShowSettingsPage
Exit Function
End If
If PL_(msg) Then
If PIBL Then Exit Function
MsgBox msg, vbCritical, ChrW(1044) & ChrW(1072) & ChrW(1083) & ChrW(1100) & ChrW(1085) & ChrW(1077) & _
ChrW(1081) & ChrW(1096) & ChrW(1077) & ChrW(1077) & ChrW(32) & ChrW(1080) & ChrW(1089) & ChrW(1087) & _
ChrW(1086) & ChrW(1083) & ChrW(1100) & ChrW(1079) & ChrW(1086) & ChrW(1074) & ChrW(1072) & ChrW(1085) & _
ChrW(1080) & ChrW(1077) & ChrW(32) & ChrW(1087) & ChrW(1088) & ChrW(1086) & ChrW(1075) & ChrW(1088) & _
ChrW(1072) & ChrW(1084) & ChrW(1084) & ChrW(1099) & ChrW(32) & ChrW(171) & PROJECT_NAME$ & ChrW(187) & _
ChrW(32) & ChrW(1085) & ChrW(1077) & ChrW(1074) & ChrW(1086) & ChrW(1079) & ChrW(1084) & ChrW(1086) & ChrW(1078) & ChrW(1085) & ChrW(1086) & ChrW(33)
F_About.Show
F_About.MultiPage1.Value = 1
StopMacro = True
Exit Function
End If
For i = coll.Count To 1 Step -1
filename$ = coll(i)
ttype$ = TemplateType(filename)
If ttype$ = "" Then
N& = N& + 1
Select Case N
Case Is < 4: msg$ = msg$ & Replace(filename, TEMPLATES_FOLDER$, "") & vbNewLine
Case 4: msg$ = msg$ & "и т.д." & vbNewLine
Case Else
End Select
coll.Remove i
End If
Next i
If coll.Count > 200 Then
msg$ = "В папке с шаблонами документов обнаружено слишком много файлов (" & coll.Count & " шт.) " & _
vbNewLine & "Убедитесь, что вы верно задали папку, содержащую шаблоны документов." & vbNewLine & vbNewLine & _
"Путь к папке с шаблонами (задан в настройках программы):" & vbNewLine & TEMPLATES_FOLDER$ & _
vbNewLine & vbNewLine & "Начать заполнение документов?"
ttl$ = "Слишком много файлов шаблонов - так и должно быть?"
If MsgBox(msg, vbExclamation + vbDefaultButton2 + vbOKCancel, ttl$) = vbCancel Then
Debug.Print "Найдено дофига шаблонов: " & coll.Count
…
|
|||
Open this report in the interactive analyzer, or submit your own file for analysis.