Добавлено форматирование картинок

2025-05-17 22:39:44 +03:00
parent 935281479d
commit b403010d54
4 changed files with 277 additions and 82 deletions
--- a/Gostomizer.dotm
+++ b/Gostomizer.dotm
--- a/MacrosList.bas
+++ b/MacrosList.bas
@@ -1,86 +1,119 @@
-Sub ML_AddListA3()
-    'for debug
-    'MsgBox "Запуск функции вставки листа А3"
-    
-    Dim ps As PageSetup
-    
-    Set ps = Selection.PageSetup
-        
-    Selection.InsertBreak Type:=wdSectionBreakNextPage
-    With Selection.PageSetup
-        .LineNumbering.Active = False
-        .Orientation = wdOrientLandscape
-        .TopMargin = CentimetersToPoints(1.5)
-        .BottomMargin = CentimetersToPoints(3)
-        .LeftMargin = CentimetersToPoints(2)
-        .RightMargin = CentimetersToPoints(2)
-        .Gutter = CentimetersToPoints(0)
-        .HeaderDistance = CentimetersToPoints(1.25)
-        .FooterDistance = CentimetersToPoints(1.25)
-        .PageWidth = CentimetersToPoints(29.7)
-        .PageHeight = CentimetersToPoints(21)
-        .FirstPageTray = wdPrinterDefaultBin
-        .OtherPagesTray = wdPrinterDefaultBin
-        .SectionStart = wdSectionNewPage
-        .OddAndEvenPagesHeaderFooter = False
-        .DifferentFirstPageHeaderFooter = False
-        .VerticalAlignment = wdAlignVerticalTop
-        .SuppressEndnotes = False
-        .MirrorMargins = False
-        .TwoPagesOnOne = False
-        .BookFoldPrinting = False
-        .BookFoldRevPrinting = False
-        .BookFoldPrintingSheets = 1
-        .GutterPos = wdGutterPosLeft
-    End With
-    
-    Selection.InsertBreak Type:=wdSectionBreakNextPage
-    Selection.PageSetup = ps
-End Sub
-
 Sub ML_AddListA4()
    'for debug
    'MsgBox "Запуск функции вставки листа А4"
    
-    MsgBox "до Selection.PageSetup.Orientation = " & Selection.PageSetup.Orientation
+    'Dim ps As PageSetup
    
+    'Set ps = Selection.PageSetup
+    
+    'Loas inserting as new chapter/breaks
    Selection.InsertBreak Type:=wdSectionBreakNextPage
+    Selection.InsertBreak Type:=wdSectionBreakNextPage
+    Selection.MoveLeft Unit:=wdCharacter, Count:=1
+    
+    'wdPaperSize - https://learn.microsoft.com/en-us/office/vba/api/word.wdpapersize
+    'wdPaperA3 = 6
+    'wdPaperA4 = 7
+    
    With Selection.PageSetup
-        .LineNumbering.Active = False
-        .Orientation = wdOrientPortrait
+        .PaperSize = wdPaperA4
+        .Orientation = wdOrientLandscape
        .TopMargin = CentimetersToPoints(2)
        .BottomMargin = CentimetersToPoints(2)
        .LeftMargin = CentimetersToPoints(3)
        .RightMargin = CentimetersToPoints(1.5)
-        .Gutter = CentimetersToPoints(0)
-        .HeaderDistance = CentimetersToPoints(1.25)
-        .FooterDistance = CentimetersToPoints(1.25)
-        .PageWidth = CentimetersToPoints(29.7)
-        .PageHeight = CentimetersToPoints(42)
-        .FirstPageTray = wdPrinterDefaultBin
-        .OtherPagesTray = wdPrinterDefaultBin
-        .SectionStart = wdSectionNewPage
-        .OddAndEvenPagesHeaderFooter = False
-        .DifferentFirstPageHeaderFooter = False
-        .VerticalAlignment = wdAlignVerticalTop
-        .SuppressEndnotes = False
-        .MirrorMargins = False
-        .TwoPagesOnOne = False
-        .BookFoldPrinting = False
-        .BookFoldRevPrinting = False
-        .BookFoldPrintingSheets = 1
-        .GutterPos = wdGutterPosLeft
    End With
    
-    MsgBox "после Selection.PageSetup.Orientation = " & Selection.PageSetup.Orientation
+    'With Selection.PageSetup
+    '    .LineNumbering.Active = False
+    '    .Orientation = wdOrientLandscape
+    '    .TopMargin = CentimetersToPoints(1.5)
+    '    .BottomMargin = CentimetersToPoints(3)
+    '    .LeftMargin = CentimetersToPoints(2)
+    '    .RightMargin = CentimetersToPoints(2)
+    '    .Gutter = CentimetersToPoints(0)
+    '    .HeaderDistance = CentimetersToPoints(1.25)
+    '    .FooterDistance = CentimetersToPoints(1.25)
+    '    .PageWidth = CentimetersToPoints(29.7)
+    '    .PageHeight = CentimetersToPoints(21)
+    '    .FirstPageTray = wdPrinterDefaultBin
+    '    .OtherPagesTray = wdPrinterDefaultBin
+    '    .SectionStart = wdSectionNewPage
+    '    .OddAndEvenPagesHeaderFooter = False
+    '    .DifferentFirstPageHeaderFooter = False
+    '    .VerticalAlignment = wdAlignVerticalTop
+    '    .SuppressEndnotes = False
+    '    .MirrorMargins = False
+    '    .TwoPagesOnOne = False
+    '    .BookFoldPrinting = False
+    '    .BookFoldRevPrinting = False
+    '    .BookFoldPrintingSheets = 1
+    '    .GutterPos = wdGutterPosLeft
+    'End With
    
-    If Selection.PageSetup.Orientation = wdOrientPortrait Then
-        MsgBox "Портретная"
-        Selection.PageSetup.Orientation = wdOrientLandscape
-    Else
-        MsgBox "Альбомная"
-        Selection.PageSetup.Orientation = wdOrientPortrait
-    End If
+    
+End Sub
+
+Sub ML_AddListA3()
+    'for debug
+    'MsgBox "Запуск функции вставки листа А3"
+    'MsgBox "до Selection.PageSetup.Orientation = " & Selection.PageSetup.Orientation
+    
+    'Loas inserting as new chapter/breaks
+    Selection.InsertBreak Type:=wdSectionBreakNextPage
+    Selection.InsertBreak Type:=wdSectionBreakNextPage
+    Selection.MoveLeft Unit:=wdCharacter, Count:=1
+    
+    'wdPaperSize - https://learn.microsoft.com/en-us/office/vba/api/word.wdpapersize
+    'wdPaperA3 = 6
+    'wdPaperA4 = 7
+    
+    With Selection.PageSetup
+        .PaperSize = wdPaperA3
+        .Orientation = wdOrientLandscape
+        .TopMargin = CentimetersToPoints(2)
+        .BottomMargin = CentimetersToPoints(2)
+        .LeftMargin = CentimetersToPoints(3)
+        .RightMargin = CentimetersToPoints(1.5)
+    End With
+    
+    'With Selection.PageSetup
+    '    .LineNumbering.Active = False
+    '    .Orientation = wdOrientPortrait
+    '    .TopMargin = CentimetersToPoints(2)
+    '    .BottomMargin = CentimetersToPoints(2)
+    '    .LeftMargin = CentimetersToPoints(3)
+    '    .RightMargin = CentimetersToPoints(1.5)
+    '    .Gutter = CentimetersToPoints(0)
+    '    .HeaderDistance = CentimetersToPoints(1.25)
+    '    .FooterDistance = CentimetersToPoints(1.25)
+    '    '.PageWidth = CentimetersToPoints(29.7)
+    '    '.PageHeight = CentimetersToPoints(42)
+    '    .PaperSize = wdPaperA3
+    '    .FirstPageTray = wdPrinterDefaultBin
+    '    .OtherPagesTray = wdPrinterDefaultBin
+    '    .SectionStart = wdSectionNewPage
+    '    .OddAndEvenPagesHeaderFooter = False
+    '    .DifferentFirstPageHeaderFooter = False
+    '    .VerticalAlignment = wdAlignVerticalTop
+    '    .SuppressEndnotes = False
+    '    .MirrorMargins = False
+    '    .TwoPagesOnOne = False
+    '    .BookFoldPrinting = False
+    '    .BookFoldRevPrinting = False
+    '    .BookFoldPrintingSheets = 1
+    '    .GutterPos = wdGutterPosLeft
+    'End With
+    
+    'MsgBox "после Selection.PageSetup.Orientation = " & Selection.PageSetup.Orientation
+    
+    'If Selection.PageSetup.Orientation = wdOrientPortrait Then
+    '    MsgBox "Портретная"
+    '    Selection.PageSetup.Orientation = wdOrientLandscape
+    'Else
+    '    MsgBox "Альбомная"
+    '    Selection.PageSetup.Orientation = wdOrientPortrait
+    'End If
    
 End Sub

@@ -196,5 +229,156 @@ Dim CurrTbl As Table
    
    
 End Sub
+Sub ML_PicFormatter()
+    
+    Dim PicWidth, PicHeight, PicWidthA4, PicHeightA4, PicWidthA3, PicHeightA3 As Single
+        
+    'настройка размера картиное
+    'для а4
+    PicWidth = 15
+    PicHeight = 15
+    
+    'для а4 альбомного
+    PicWidthA4 = 25
+    PicHeightA4 = 15
+    
+    'для а3 альбомного
+    PicWidthA3 = 37
+    PicHeightA3 = 24
+    
+    'определяем тип оъекта в выделении
+    'MsgBox "pic in selection = " & Selection.ShapeRange.Count
+    'MsgBox "pic in inline selection = " & Selection.InlineShapes.Count
+    
+    ' WdSelectionType =
+    ' https://learn.microsoft.com/en-us/office/vba/api/word.wdselectiontype
+    'MsgBox "Selection.Type = " & Selection.Type
+    
+    'определяем тип фигуры
+    ' WdInlineShapeType =
+    ' https://learn.microsoft.com/ru-ru/office/vba/api/word.wdinlineshapetype
+    'MsgBox "WdInlineShapeType = " & Selection.InlineShapes(1).Type
    
    
+    'проверка на выделение картинки
+    'wdSelectionInlineShape = 7 Inline shape
+    'MsgBox "выделено картинок = " & Selection.InlineShapes.Count
+       
+    If Selection.InlineShapes.Count > 0 Then
+        'MsgBox "поехали форматировать"
+        
+        'проверяем ориентацию листа
+        If Selection.PageSetup.Orientation = wdOrientLandscape Then
+            'альбомная, может быть А4 и А3
+            'MsgBox "Orientation = Landscape"
+            
+            
+            If Selection.PageSetup.PaperSize = 7 Then
+                'MsgBox ("A4")
+                PicWidth = PicWidthA4
+                PicHeight = PicHeightA4
+            End If
+    
+            If Selection.PageSetup.PaperSize = 6 Then
+                'MsgBox ("A3")
+                PicWidth = PicWidthA3
+                PicHeight = PicHeightA3
+            End If
+            
+            'проверяем ширину картинки
+            'MsgBox "width = " & PointsToCentimeters(Selection.InlineShapes(1).Width) & " / " & PicWidth
+            If PointsToCentimeters(Selection.InlineShapes(1).Width) > PicWidth Then
+                'устанавливаем ширину в точках
+                Selection.InlineShapes(1).Width = CentimetersToPoints(PicWidth)
+            End If
+            
+            'проверяем высоту картинки
+            'MsgBox "height = " & PointsToCentimeters(Selection.InlineShapes(1).Width) & " / " & PicHeight
+            If PointsToCentimeters(Selection.InlineShapes(1).Height) > PicHeight Then
+                'устанавливаем высоту в точках
+                Selection.InlineShapes(1).Height = CentimetersToPoints(PicHeight)
+            End If
+            
+        Else 'orientation
+            'портретная - только для А4, проверяем только ширину
+            'MsgBox "Orientation = Portrait"
+            
+            'проверяем ширину картинки
+            'MsgBox "width = " & PointsToCentimeters(Selection.InlineShapes(1).Width)
+            If PointsToCentimeters(Selection.InlineShapes(1).Width) > PicWidth Then
+                'устанавливаем ширину в точках
+                Selection.InlineShapes(1).Width = CentimetersToPoints(PicWidth)
+            End If
+            
+        End If 'orientation
+        
+        'выравниваем по центру
+        'Selection.InlineShapes(1).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
+        With Selection.InlineShapes(1).Range.ParagraphFormat
+            .Alignment = wdAlignParagraphCenter
+            .SpaceBeforeAuto = False
+            .SpaceAfterAuto = False
+            .FirstLineIndent = CentimetersToPoints(0)
+        End With
+        
+        'применение стиля и вставка названия
+        'Selection.Style = ActiveDocument.Styles("???????")
+        'add autonumber + set style
+        'Selection.InsertCaption Label:="???????", TitleAutoText:="InsertCaption1", _
+        ' Title:=" - ", Position:=wdCaptionPositionBelow, ExcludeLabel:=0
+        'Selection.Style = ActiveDocument.Styles("???????? ???????")
+        
+        Selection.InlineShapes(1).Select
+                
+                
+        'Label = WdCaptionLabelID - https://learn.microsoft.com/ru-ru/office/vba/api/word.wdcaptionlabelid
+        'при испоьзовании WdCaptionLabelID вставляется английское название
+        'wdCaptionEquation = -3 формула
+        'wdCaptionFigure = -1 рисунок
+        'wdCaptionTable = -2 таблица
+        'Position = WdCaptionPosition - https://learn.microsoft.com/ru-ru/office/vba/api/word.wdcaptionposition
+        'wdCaptionPositionAbove = 0 до объекта
+        'wdCaptionPositionBelow = 1 после объекта
+        Selection.InsertCaption Label:="Рисунок", Title:=" - " ', Position:=wdCaptionPositionBelow
+        
+        
+        
+        
+        
+        
+        
+    Else 'нет картинок
+        MsgBox "Не выделена картинка!"
+    End If 'проверка на картинки
+    
+    
+    'устанавливаем ширину в точках
+    'Selection.InlineShapes(1).Width = CentimetersToPoints(15)
+    
+    
+    
+
+End Sub
+
+Sub ML_TestMacros()
+
+    MsgBox ("Хоба!")
+    
+    MsgBox "Papersize = " & Selection.PageSetup.PaperSize
+    'wdPaperSize - https://learn.microsoft.com/en-us/office/vba/api/word.wdpapersize
+    'wdPaperA3 = 6
+    'wdPaperA4 = 7
+    
+    If Selection.PageSetup.PaperSize = 7 Then
+        MsgBox ("A4")
+    End If
+    
+    If Selection.PageSetup.PaperSize = 6 Then
+        MsgBox ("A3")
+    End If
+    
+    
+        
+        
+    
+End Sub
--- a/README.md
+++ b/README.md
@@ -7,21 +7,24 @@ C:\Users\[ИмяПользователя]\AppData\Roaming\Microsoft\Word\STARTUP


 ## Текущий набор функций:
-1. Форматирование таблицы по ГОСТ
-2. Добавление нового раздела после курсора с горизонтальным листом А4
-3. Добавление нового раздела после курсора с горизонтальным листом А3
+1. Форматирование таблицы по ГОСТ;
+2. Форматирование картинки со вставкой названия. Размер картинки уменьшается до определенного размера, который зависит от формата (а3/а4) и ориентации листа (портретный/альбомный);
+2. Добавление нового раздела после курсора с горизонтальным листом А4;
+3. Добавление нового раздела после курсора с горизонтальным листом А3;


 ## Планируемые функции
-1. Форматироание картинки
-2. Автоматическая установка расширения при открытии
-3. Вставка штампов целиком и частями
-4. Добавления ряда интересных функций из addin_wordtools
-5. Добавления ряда интересных функций из addin_macrotoolsword
-6. вставка вертикальных листов как опция, выбор по выпадающему списку из кнопки
-7. Добавление подготовленных стилей в документ, чтобы форматирование картинки или таблицы происходило корректно. Изменение текущих стилей документа. Или приведение стилей к определенному шаблону.
+1. Автоматическая установка расширения при открытии
+2. Вставка штампов целиком и частями
+3. Добавления ряда интересных функций из addin_wordtools
+4. Добавления ряда интересных функций из addin_macrotoolsword
+5. вставка вертикальных листов как опция, выбор по выпадающему списку из кнопки
+6. Добавление подготовленных стилей в документ, чтобы форматирование картинки или таблицы происходило корректно. Изменение текущих стилей документа. Или приведение стилей к определенному шаблону.

 ## Планируемые доработки скриптов
 1. Форматирование таблицы - автоматическое определение формата листа и подгон ширины под формат листа.
 2. Вставка горизонтального листа. После вставки горинзонтального листа следующие страницы превращаются также в горизонтальные. Надо сделать так чтобы вставлялся только один горизонтальный лист как раздел, а следующие разделы шли без изменения.
 3. Добавить в форматирование таблицы вставку названия
+
+## Выполненные доработки
+1. Добавлена функция форматирования картинки со вставкой названия. Размер картинки уменьшается до определенного размера, который зависит от формата (а3/а4) и ориентации листа (портретный/альбомный);
--- a/RibbonCallbacks.bas
+++ b/RibbonCallbacks.bas
@@ -10,7 +10,10 @@ End Sub

 'PicFormatter (элемент: button, атрибут: onAction), 2010+
 Private Sub PicFormatter(control As IRibbonControl)
-    MsgBox "Сработала процедура, заданная в onAction элемента " & control.ID
+    'MsgBox "Сработала процедура, заданная в onAction элемента " & control.ID
+
+    Call ML_PicFormatter
+
 End Sub

 'AddListA4 (элемент: button, атрибут: onAction), 2010+
@@ -64,3 +67,8 @@ Private Sub AddPageNumber(control As IRibbonControl)
    MsgBox "Сработала процедура, заданная в onAction элемента " & control.ID
 End Sub

+'TestMacros (элемент: button, атрибут: onAction), 2010+
+Private Sub TestMacros(control As IRibbonControl)
+    'MsgBox "Сработала процедура, заданная в onAction элемента " & control.ID
+    Call ML_TestMacros
+End Sub