Files
Gostomizer/MacrosList.bas

588 lines
21 KiB
QBasic
Raw Blame History

This file contains ambiguous Unicode characters
This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.
Sub ML_AddListA4()
'for debug
'MsgBox "Запуск функции вставки листа А4"
'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
.PaperSize = wdPaperA4
.Orientation = wdOrientLandscape
.TopMargin = CentimetersToPoints(2)
.BottomMargin = CentimetersToPoints(2)
.LeftMargin = CentimetersToPoints(3)
.RightMargin = CentimetersToPoints(1.5)
End With
'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
End Sub
Sub ML_AddListA4vert()
'for debug
'MsgBox "Запуск функции вставки листа А4 вертикального"
'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
'WdOrientation - https://learn.microsoft.com/ru-ru/office/vba/api/word.wdorientation
'wdOrientPortrait = 0
'wdOrientLandscape =1
With Selection.PageSetup
.PaperSize = wdPaperA4
.Orientation = wdOrientPortrait
.TopMargin = CentimetersToPoints(2)
.BottomMargin = CentimetersToPoints(2)
.LeftMargin = CentimetersToPoints(3)
.RightMargin = CentimetersToPoints(1.5)
End With
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
'WdOrientation - https://learn.microsoft.com/ru-ru/office/vba/api/word.wdorientation
'wdOrientPortrait = 0
'wdOrientLandscape =1
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
Sub ML_TableFormatter()
Dim CurrTbl As Table
If Selection.Tables.Count >= 1 Then
'MsgBox ("выбрана таблица")
Set CurrTbl = Selection.Tables(1)
CurrTbl.Select
'MsgBox ("выбрана эта таблица")
'Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
Selection.ParagraphFormat.Alignment = wdAlignParagraphLeft
Selection.Cells.VerticalAlignment = wdCellAlignVerticalCenter
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
With Selection.Rows
.HeightRule = wdRowHeightAtLeast
.Height = CentimetersToPoints(0.7)
.AllowBreakAcrossPages = False
End With
With Selection.Tables(1)
.TopPadding = CentimetersToPoints(0.05)
.BottomPadding = CentimetersToPoints(0.05)
.LeftPadding = CentimetersToPoints(0.05)
.RightPadding = CentimetersToPoints(0.05)
.Spacing = 0
.AllowPageBreaks = True
.AllowAutoFit = False
.PreferredWidthType = wdPreferredWidthPoints
.Rows.LeftIndent = CentimetersToPoints(0.1)
.PreferredWidth = CentimetersToPoints(17.3)
With .Borders(wdBorderLeft)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth150pt
.Color = wdColorAutomatic
End With
With .Borders(wdBorderRight)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth150pt
.Color = wdColorAutomatic
End With
With .Borders(wdBorderTop)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth150pt
.Color = wdColorAutomatic
End With
With .Borders(wdBorderVertical)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth150pt
.Color = wdColorAutomatic
End With
With .Borders(wdBorderHorizontal)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth050pt
.Color = wdColorAutomatic
End With
With .Borders(wdBorderBottom)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth150pt
.Color = wdColorAutomatic
End With
End With
With Selection.Rows(1)
.Height = CentimetersToPoints(1.4)
.HeadingFormat = True
With .Borders(wdBorderLeft)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth150pt
.Color = wdColorAutomatic
End With
With .Borders(wdBorderRight)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth150pt
.Color = wdColorAutomatic
End With
With .Borders(wdBorderTop)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth150pt
.Color = wdColorAutomatic
End With
With .Borders(wdBorderBottom)
.LineStyle = wdLineStyleDouble
'.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth150pt
.Color = wdColorAutomatic
End With
End With
CurrTbl.Rows(1).Select
'MsgBox ("выбрана первая строчка")
Selection.Rows(1).Select
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
Selection.Cells.VerticalAlignment = wdCellAlignVerticalCenter
'MsgBox ("первая строка отформатирована")
'MsgBox ("Done!")
'MsgBox ("Готово!")
Else
'MsgBox ("Table not select !")
MsgBox ("Не выбрана таблица !")
End If
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_AddStyle()
'Добавление стиля для названия рисунка
ActiveDocument.Styles.Add Name:="Название Рисунка", Type:= _
wdStyleTypeParagraph
ActiveDocument.Styles("Название Рисунка").AutomaticallyUpdate = False
With ActiveDocument.Styles("Название Рисунка").Font
.Name = "Arial"
.Size = 14
.Bold = False
.Italic = False
.Underline = wdUnderlineNone
.UnderlineColor = wdColorAutomatic
.StrikeThrough = False
.DoubleStrikeThrough = False
.Outline = False
.Emboss = False
.Shadow = False
.Hidden = False
.SmallCaps = False
.AllCaps = False
.Color = wdColorAutomatic
.Engrave = False
.Superscript = False
.Subscript = False
.Scaling = 100
.Kerning = 0
.Animation = wdAnimationNone
.Ligatures = wdLigaturesNone
.NumberSpacing = wdNumberSpacingDefault
.NumberForm = wdNumberFormDefault
.StylisticSet = wdStylisticSetDefault
.ContextualAlternates = 0
End With
With ActiveDocument.Styles("Название Рисунка").ParagraphFormat
.LeftIndent = CentimetersToPoints(0)
.RightIndent = CentimetersToPoints(0)
.SpaceBefore = 0
.SpaceBeforeAuto = False
.SpaceAfter = 6
.SpaceAfterAuto = False
.LineSpacingRule = wdLineSpace1pt5
.Alignment = wdAlignParagraphCenter
.WidowControl = True
.KeepWithNext = False
.KeepTogether = False
.PageBreakBefore = False
.NoLineNumber = False
.Hyphenation = True
.FirstLineIndent = CentimetersToPoints(0)
.OutlineLevel = wdOutlineLevelBodyText
.CharacterUnitLeftIndent = 0
.CharacterUnitRightIndent = 0
.CharacterUnitFirstLineIndent = 0
.LineUnitBefore = 0
.LineUnitAfter = 0
.MirrorIndents = False
.TextboxTightWrap = wdTightNone
End With
ActiveDocument.Styles("Название Рисунка"). _
NoSpaceBetweenParagraphsOfSameStyle = False
ActiveDocument.Styles("Название Рисунка").ParagraphFormat.TabStops. _
ClearAll
With ActiveDocument.Styles("Название Рисунка").ParagraphFormat
With .Shading
.Texture = wdTextureNone
.ForegroundPatternColor = wdColorAutomatic
.BackgroundPatternColor = wdColorAutomatic
End With
.Borders(wdBorderLeft).LineStyle = wdLineStyleNone
.Borders(wdBorderRight).LineStyle = wdLineStyleNone
.Borders(wdBorderTop).LineStyle = wdLineStyleNone
.Borders(wdBorderBottom).LineStyle = wdLineStyleNone
With .Borders
.DistanceFromTop = 1
.DistanceFromLeft = 4
.DistanceFromBottom = 1
.DistanceFromRight = 4
.Shadow = False
End With
End With
ActiveDocument.Styles("Название Рисунка").LanguageID = wdRussian
ActiveDocument.Styles("Название Рисунка").NoProofing = False
ActiveDocument.Styles("Название Рисунка").Frame.Delete
'Добавление стиля для названия таблицы
ActiveDocument.Styles.Add Name:="Название Таблицы", Type:= _
wdStyleTypeParagraph
ActiveDocument.Styles("Название Таблицы").AutomaticallyUpdate = False
With ActiveDocument.Styles("Название Таблицы").Font
.Name = "Arial"
.Size = 14
.Bold = False
.Italic = False
.Underline = wdUnderlineNone
.UnderlineColor = wdColorAutomatic
.StrikeThrough = False
.DoubleStrikeThrough = False
.Outline = False
.Emboss = False
.Shadow = False
.Hidden = False
.SmallCaps = False
.AllCaps = False
.Color = wdColorAutomatic
.Engrave = False
.Superscript = False
.Subscript = False
.Scaling = 100
.Kerning = 0
.Animation = wdAnimationNone
.Ligatures = wdLigaturesNone
.NumberSpacing = wdNumberSpacingDefault
.NumberForm = wdNumberFormDefault
.StylisticSet = wdStylisticSetDefault
.ContextualAlternates = 0
End With
With ActiveDocument.Styles("Название Таблицы").ParagraphFormat
.LeftIndent = CentimetersToPoints(0)
.RightIndent = CentimetersToPoints(0)
.SpaceBefore = 0
.SpaceBeforeAuto = False
.SpaceAfter = 0
.SpaceAfterAuto = False
.LineSpacingRule = wdLineSpaceSingle
.Alignment = wdAlignParagraphLeft
.WidowControl = True
.KeepWithNext = False
.KeepTogether = False
.PageBreakBefore = False
.NoLineNumber = False
.Hyphenation = True
.FirstLineIndent = CentimetersToPoints(0)
.OutlineLevel = wdOutlineLevelBodyText
.CharacterUnitLeftIndent = 0
.CharacterUnitRightIndent = 0
.CharacterUnitFirstLineIndent = 0
.LineUnitBefore = 0
.LineUnitAfter = 0
.MirrorIndents = False
.TextboxTightWrap = wdTightNone
End With
ActiveDocument.Styles("Название Таблицы"). _
NoSpaceBetweenParagraphsOfSameStyle = False
ActiveDocument.Styles("Название Таблицы").ParagraphFormat.TabStops.ClearAll
With ActiveDocument.Styles("Название Таблицы").ParagraphFormat
With .Shading
.Texture = wdTextureNone
.ForegroundPatternColor = wdColorAutomatic
.BackgroundPatternColor = wdColorAutomatic
End With
.Borders(wdBorderLeft).LineStyle = wdLineStyleNone
.Borders(wdBorderRight).LineStyle = wdLineStyleNone
.Borders(wdBorderTop).LineStyle = wdLineStyleNone
.Borders(wdBorderBottom).LineStyle = wdLineStyleNone
With .Borders
.DistanceFromTop = 1
.DistanceFromLeft = 4
.DistanceFromBottom = 1
.DistanceFromRight = 4
.Shadow = False
End With
End With
ActiveDocument.Styles("Название Таблицы").LanguageID = wdRussian
ActiveDocument.Styles("Название Таблицы").NoProofing = False
ActiveDocument.Styles("Название Таблицы").Frame.Delete
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