Добрый день.
Может кто поможет... Уже какой день бьюсь с проблемой переноса прямоугольников из одного листа на принт-форму в другой лист с сохранением пропорций. Почему-то их длина и начальная позиция сьезжают...
Смысл какой - выделяю область копирования, перебираю обьекты, для каждого обьекта определяю нач позицию и длину, далее определяю пропорцию (кол-во ячеек, которое занимает рисунок), переношу это на другой лист, рисую там обьект с заданными пропорциями, а он сьезжает ...(только нехорошие слова на ум приходят
).
Возможно, кто сталкивался с подобным, укажите где может быть баг...
Файл тяжеловат для вложения...
Может кто поможет... Уже какой день бьюсь с проблемой переноса прямоугольников из одного листа на принт-форму в другой лист с сохранением пропорций. Почему-то их длина и начальная позиция сьезжают...
Смысл какой - выделяю область копирования, перебираю обьекты, для каждого обьекта определяю нач позицию и длину, далее определяю пропорцию (кол-во ячеек, которое занимает рисунок), переношу это на другой лист, рисую там обьект с заданными пропорциями, а он сьезжает ...(только нехорошие слова на ум приходят
).Возможно, кто сталкивался с подобным, укажите где может быть баг...
Файл тяжеловат для вложения...
| Код |
|---|
Application.ActiveWorkbook.Worksheets("Roboczy").Activate
Range("D72").Select
w_razmer = Selection.Width ' Размеры ячейки для пропорции - они все одинаковы по листу (кроме первых трех столбцов), поэтому беру "D"
x_razmer = Selection.Left
Worksheets("Roboczy").Range(Cells(70, 4), Cells(85, 177)).Select '"D70:FU85" ' Диапазон копирования
Set Rng = Selection
Top = Selection.Top
Lef = Selection.Left
Height = Selection.Height
Width = Selection.Width
Application.CutCopyMode = False
For Each Obg In Worksheets("Roboczy").Shapes 'Rng.Shapes
If Obg.Left >= Lef And Obg.Left < (Lef + Width) And Obg.Top >= Top And Obg.Top <= (Top + Height) Then ' проверка условия попадания в диапазон
Name = Obg.Name
h_R = Obg.Height ' хар-ки обьекта
w_R = Obg.Width
x_R = Obg.Left
y_R = Obg.Top
Name_2 = Obg.TextFrame2.TextRange.Characters.Text
ZZ = (x_R - x_razmer) / w_razmer 'w_R ' пропорция - кол-во ячеек, которое занимает рисунок
R = 0
G = 0
B = 255
With Worksheets("Print 01").Activate
Range("GD1").Select ' это проверяю границу формы
Lst_Col_x = Selection.Left
If Left(Obg.Name, 5) <> "Fact_" Then ' условия по строкам для обьектов
If Left(Obg.Name, 8) = "C1_Past_" Or Left(Obg.Name, 17) = "CIP01_M1_C1_Past_" Then
Range(Cells(10, 12 + ZZ), Cells(10, 12 + ZZ)).Select
ElseIf Left(Obg.Name, 12) = "C1_Kociol01_" Or Left(Obg.Name, 21) = "CIP01_M2_C1_Kociol01_" Then
Range(Cells(11 + ZZ, 12 + ZZ), Cells(11, 12 + ZZ)).Select
ElseIf Left(Obg.Name, 12) = "C1_Kociol02_" Or Left(Obg.Name, 21) = "CIP01_M2_C1_Kociol02_" Then
Range(Cells(12, 12 + ZZ), Cells(12, 12 + ZZ)).Select
ElseIf Left(Obg.Name, 12) = "C1_Kociol03_" Or Left(Obg.Name, 21) = "CIP01_M2_C1_Kociol03_" Then
Range(Cells(13, 12 + ZZ), Cells(13, 12 + ZZ)).Select
ElseIf Left(Obg.Name, 12) = "C1_Kociol04_" Or Left(Obg.Name, 21) = "CIP01_M2_C1_Kociol04_" Then
Range(Cells(14, 12 + ZZ), Cells(14, 12 + ZZ)).Select
ElseIf Left(Obg.Name, 11) = "C1_Bufor01_" Or Left(Obg.Name, 20) = "CIP01_M1_C1_Bufor01_" Then
Range(Cells(15, 12 + ZZ), Cells(15, 12 + ZZ)).Select
ElseIf Left(Obg.Name, 11) = "C1_Bufor02_" Or Left(Obg.Name, 20) = "CIP01_M1_C1_Bufor02_" Then
Range(Cells(16, 12 + ZZ), Cells(16, 12 + ZZ)).Select
ElseIf Left(Obg.Name, 7) = "C1_PFY_" Or Left(Obg.Name, 16) = "CIP01_M1_C1_PFY_" Then
Range(Cells(17, 12 + ZZ), Cells(17, 12 + ZZ)).Select
ElseIf Left(Obg.Name, 9) = "C1_PRASY_" Or Left(Obg.Name, 18) = "CIP01_M1_C1_PRASY_" Or Left(Obg.Name, 18) = "CIP01_M2_C1_PRASY_" Then
Range(Cells(18, 12 + ZZ), Cells(18, 12 + ZZ)).Select
ElseIf Left(Obg.Name, 9) = "C1_Wylad_" Then
Range(Cells(19, 12 + ZZ), Cells(19, 12 + ZZ)).Select
ElseIf Left(Obg.Name, 9) = "CIP01_M2_" And Len(Obg.Name) < 29 Then
Range(Cells(22, 12 + ZZ), Cells(22, 12 + ZZ)).Select
ElseIf Left(Obg.Name, 9) = "CIP01_M1_" And Len(Obg.Name) < 29 Then
Range(Cells(21, 12 + ZZ), Cells(21, 12 + ZZ)).Select
Else: Range(Cells(23, 12 + ZZ), Cells(23, 12 + ZZ)).Select
End If
x = ActiveCell.Cells.Left
y = ActiveCell.Cells.Top
w = ActiveCell.Cells.Width
h = ActiveCell.Cells.Height
End If
End With
With Application.ActiveWorkbook.Worksheets("Print 01")
If Lst_Col_x < (x + (w_R / w_razmer * w)) Then
.Shapes.AddShape(msoShapeRectangle, x, y, (Lst_Col_x - x), h).Select 'w_R / w_razmer * w ' и собственно рисунок
Else:
.Shapes.AddShape(msoShapeRectangle, x, y, (w_R / w_razmer * w), h).Select
End If
Selection.Name = Name
End With
With Selection.ShapeRange.Fill
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0
.Transparency = 0.6
.Solid
.Visible = msoTrue
If Left(Obg.Name, 3) = "CIP" Then
.ForeColor.RGB = RGB(R, G, B)
Else: .ForeColor.RGB = RGB(0, 0, 0)
End If
.BackColor.RGB = RGB(255, 255, 255)
.Patterned msoPattern5Percent
End With
With Selection.ShapeRange.Line
If Left(Obg.Name, 3) = "CIP" Then
.ForeColor.RGB = RGB(0, 0, 255)
Else: .ForeColor.RGB = RGB(0, 0, 0)
End If
.Weight = 1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0
.Transparency = 0
End With
'If Left(Name, 10) = "C1_Bufor01" Then
' Nr_str = 15
'.Shapes.AddShape(msoShapeRectangle, x + 5, y + 5, w, h).Name = Name
'Dim a() As String
'a = Split("vremya-ne-zhdet", "-", 2)
'MsgBox a(0) & vbNewLine & a(1)
Selection.ShapeRange.TextFrame2.TextRange.Font.Size = 16
Selection.ShapeRange.TextFrame2.VerticalAnchor = msoAnchorMiddle
Selection.ShapeRange.TextFrame2.TextRange.ParagraphFormat.Alignment = _
msoAlignCenter
With Selection.ShapeRange.TextFrame2.TextRange.Font.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorText1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0
.Transparency = 0
.Solid
End With
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = Name_2
End If
Next
Application.ScreenUpdating = True
Range("U2").Value = prt_day
End Sub
|
