Тема: Проблема в objSSLocal.Select acSelectionSetCrossing, corner1, corner2, groupCode, dataValue или лыжи не едут?
Задача.
Необходимо проверить трассу на необходимость построение полок и срезок в зависимости от поперечного и продольного уклона.
Решение.
Все работает, но долго: для трассы примерное 7-10 км время обработки составляет примерно 30-50 мин. Пытаюсь оптимизировать.
Оптимизация.
Для рабочего алгоритма программа:
1. Разбивает трассу поиска с заданным шагом. (строиться дублер полинии)
2. Выделяет все полилинии в в объекте по фильтру (слой и объект - полиния).
3. Потом перебором всех полилиний из выборки для каждой разбитой точки на полилинии строиться отрезок ищется его пересечение и пишется в фаил экселя.
Соответственное очень большой объем не нужных постороений:
Хотел сделать выборку по квадрату для данной точки, но она не корректно работает пишутся нули.
Attribute VB_Name = "Section"
Option Explicit
Const a1 = 1 'Столбец - пустая константа
Const a2 = 2 'Столбец - нумерация сечений в файле
Const a3 = 3 'Столбец - знак "ПК"
Const a4 = 4 'Столбец - целая часть ПК
Const a5 = 5 'Столбец - знак "+"
Const a6 = 6 'Столбец - плюсовка ПК
Const a7 = 7 'Столбец - нумерация сечений в файле EXcel
Const a8 = 8 'Столбец - нумерация сечений в файле EXcel
Const a9 = 9 'Столбец - нумерация сечений в файле EXcel
Const a10 = 10 'Столбец - нумерация сечений в файле EXcel
Const a11 = 11 'Столбец - нумерация сечений в файле EXcel
Const a12 = 12 'Столбец - Базовая координата сечения X
Const a13 = 13 'Столбец - Базовая координата сечения Y
Const a14 = 14 'Укзатель на координату (то что не пустая ячейка с координатой)
Const A = 40 '
Const PI = 3.14159265358979
Const MscaleX = 1000
Const MscaleY = 100
Const BeginPiket = "0+00" 'Начальный ПК
Const Step = 10 'Щаг разбивки полилинии
Const StandartPiket = 100 'Стандартный 100 метровый пикет
Const StandartKM = 1000 'Стандартный 100 метровый пикет
Const BeginRow = 5 'Начало заполнения по строкам
Const Polosa = 30 'Ширина исследуемой зоны
Public i, j, k, n, m, p As Integer
Public objExcelSheet As Object
Public objExcel As Object
Public lineObj As AcadLine
Public TextObj As AcadText
Public plineObj As AcadLWPolyline
Public MLeader As AcadMLeader
Public dimObj As AcadDimAligned
Public Sub PreparationLayers()
'Слой и характеристики для полок и срезок
Set newLayer = ThisDrawing.Layers.Add("_ЛО_Полки_Срезки")
newLayer.Lineweight = acLnWt035
newLayer.Linetype = "Continuous"
newLayer.color = acGreen
'Слой и характеристики для полок и срезок
Set newLayer = ThisDrawing.Layers.Add("_ЛО_Полки_Срезки_вспомогательный")
newLayer.Lineweight = acLnWt035
newLayer.Linetype = "Continuous"
newLayer.color = acRed
'Слой и характеристики для полок и срезок
Set newLayer = ThisDrawing.Layers.Add("_ЛО_Полки_Срезки_Текст")
newLayer.Lineweight = acLnWt035
newLayer.Linetype = "Continuous"
newLayer.color = acRed
Set newLayer = ThisDrawing.Layers.Add("_ЛО_Размеры")
newLayer.Lineweight = acLnWt035 'acLnWtByLwDefault
newLayer.Linetype = "Continuous"
newLayer.color = acMagenta
End Sub
Public Sub MainSection()
Dim objSSLocal, objSSLocal1, objSSLocal2 As AcadSelectionSet
Dim Res As String
Dim SelectName As String
PreparationLayers 'Подготовка слоев
SelectionDelete "N1"
SelectName = "N1"
Set objSSLocal = SelectPolylineAll("N2")
Set objExcel = GetObject(, "Excel.Application")
objExcel.Worksheets("Poperechnik").Activate
objExcel.Worksheets("Poperechnik").Select
ThisDrawing.Utility.Prompt "Выбирите полилинию трассы"
Set objSS = ThisDrawing.SelectionSets.Add(SelectName)
objSS.SelectOnScreen
Set plineObj = objSS.Item(0)
Perpendikular plineObj, Polosa 'Сбор координат точек
SortCoordinate 'ОБЯЗАТЕЛЬНО ПЕРВАЯ после сбора точек
NumberPiket 'Прочая информация по сечениям
CalculateUklonGorizont 'Расчет уклона по горизонталям
CalculatePolok 'Определение типа полок
RazmetkaPolokDim 'Разметка полок
End Sub
Public Sub Perpendikular(plineObjLocal As AcadLWPolyline, Lkorodor As Double)
Dim AngleLine As String 'Угол в радианах поворота граничного участка PolyLine
Dim objSSLocalPer As AcadSelectionSet 'Локальная выборка
Dim Coord As Variant
Dim CrossPoints As Variant
Dim StartpointGor(0 To 2) As Double
Dim EndpointGor(0 To 2) As Double
Dim NStartpointGor(0 To 2) As Double
Dim NEndpointGor(0 To 2) As Double
Dim TextPoint(0 To 2) As Double
Dim LocalCorner(0 To 3) As Double
Dim LocalCornerVar As Double
Dim PointT(0 To 11) As Double
Set objExcel = GetObject(, "Excel.Application")
objExcel.Worksheets("Poperechnik").Activate
objExcel.Worksheets("Poperechnik").Select
i = 0
'Зануление массива данных для поперечников
Coord = plineObjLocal.Coordinates
'Перебираем каждую горизонталь на предмет пересечения уровнем
Set objSSLocalPer = SelectPolylineAll("N2")
For i = 1 To (UBound(plineObj.Coordinates) - 1) / 2
m = a14
'Создани линий по плану полилинии для определения угла AngleLine
StartpointGor(0) = Coord(2 * i - 2)
StartpointGor(1) = Coord(2 * i - 1)
StartpointGor(2) = 0
EndpointGor(0) = Coord(2 * i)
EndpointGor(1) = Coord(2 * i + 1)
EndpointGor(2) = 0
Set lineObj = ThisDrawing.ModelSpace.AddLine(StartpointGor, EndpointGor)
AngleLine = lineObj.Angle
'If StartpointGor(0) > EndpointGor(0) Then
'AngleLine = AngleLine + PI
'End If
'Удаление линий по плану полилинии для определения угла AngleLine
lineObj.Delete
'Выбираем все горизонтали (пофильтру: полилиния, слой, границы (для теста "LO"))
'LocalCorner(0) = Coord(2 * i - 2) + Lkorodor '* Cos(PI / 2 - AngleLine)
'LocalCorner(1) = Coord(2 * i - 1) - Lkorodor '* Sin(PI / 2 - AngleLine)
'LocalCorner(2) = Coord(2 * i - 2) - Lkorodor '* Cos(PI / 2 - AngleLine)
'LocalCorner(3) = Coord(2 * i - 1) + Lkorodor '* Sin(PI / 2 - AngleLine)
'objExcel.Worksheets("Poperechnik").Cells(i + BeginRow - 1, a8) = LocalCorner(0)
'objExcel.Worksheets("Poperechnik").Cells(i + BeginRow - 1, a9) = LocalCorner(1)
'objExcel.Worksheets("Poperechnik").Cells(i + BeginRow - 1, a10) = LocalCorner(2)
'objExcel.Worksheets("Poperechnik").Cells(i + BeginRow - 1, a11) = LocalCorner(3)
'PointT(0) = LocalCorner(0)
'PointT(1) = LocalCorner(1)
'PointT(2) = LocalCorner(2)
'PointT(3) = LocalCorner(1)
'PointT(4) = LocalCorner(2)
'PointT(5) = LocalCorner(3)
'PointT(6) = LocalCorner(0)
'PointT(7) = LocalCorner(3)
'PointT(8) = LocalCorner(0)
'PointT(9) = LocalCorner(1)
'PointT(10) = LocalCorner(2)
'PointT(11) = LocalCorner(3)
'Set plineObj = ThisDrawing.ModelSpace.AddLightWeightPolyline(PointT)
'Set objSSLocalPer = SelectPolyline("N2", LocalCorner(0), LocalCorner(1), LocalCorner(2), LocalCorner(3))
For j = 0 To objSSLocalPer.count - 1
Set plineObjLocal = objSSLocalPer.Item(j)
'If Int(plineObjLocal.Elevation) <> plineObjLocal.Elevation Then
NStartpointGor(0) = StartpointGor(0) - Lkorodor * Cos(PI / 2 - AngleLine)
NStartpointGor(1) = StartpointGor(1) + Lkorodor * Sin(PI / 2 - AngleLine)
NStartpointGor(2) = plineObjLocal.Elevation
NEndpointGor(0) = StartpointGor(0) + Lkorodor * Cos(PI / 2 - AngleLine)
NEndpointGor(1) = StartpointGor(1) - Lkorodor * Sin(PI / 2 - AngleLine)
NEndpointGor(2) = plineObjLocal.Elevation
Set lineObj = ThisDrawing.ModelSpace.AddLine(NStartpointGor, NEndpointGor)
CrossPoints = plineObjLocal.IntersectWith(lineObj, acExtendNone)
lineObj.Delete
If UBound(CrossPoints) > 1 Then
For n = 0 To (UBound(CrossPoints))
objExcel.Worksheets("Poperechnik").Cells(i + BeginRow - 1, m) = CrossPoints(n)
m = m + 1
Next n
End If
'End If
Next j
objExcel.Worksheets("Poperechnik").Cells(i + BeginRow - 1, a12) = Coord((i - 1) * 2)
objExcel.Worksheets("Poperechnik").Cells(i + BeginRow - 1, a13) = Coord((i - 1) * 2 + 1)
Set TextObj = ThisDrawing.ModelSpace.AddText(i, StartpointGor, 2.5)
Next i
End Sub
Private Sub SelectionDelete(SelectName As String) 'Зачистка существующих выборок
Set objSSS = ThisDrawing.SelectionSets
For Each objSS In objSSS
If objSS.Name = SelectName Then
ThisDrawing.SelectionSets.Item(SelectName).Delete
Exit For
End If
Next
End Sub
Function SelectPolyline(nameSBR As String, LocalC1, LocalC2, LocalC3, LocalC4 As Double) As AcadSelectionSet
Dim objSSLocal As AcadSelectionSet
Dim gpCode(0 To 1) As Integer
Dim dataValue(0 To 1) As Variant
Dim groupCode, dataCode As Variant
Dim corner1(0 To 2) As Double
Dim corner2(0 To 2) As Double
corner1(0) = LocalC1
corner1(1) = LocalC2
corner1(2) = 0
corner2(0) = LocalC3
corner2(1) = LocalC4
corner2(2) = 0
SelectionDelete nameSBR
gpCode(0) = 0: dataValue(0) = "LWPolyline"
gpCode(1) = 8: dataValue(1) = "LO"
groupCode = gpCode
dataCode = dataValue
Set objSSLocal = ThisDrawing.SelectionSets.Add(nameSBR)
objSSLocal.Select acSelectionSetCrossing, corner1, corner2, groupCode, dataValue
Set SelectPolyline = objSSLocal
End Function
Function SelectPolylineAll(nameSBR As String) As AcadSelectionSet
Dim objSSLocal As AcadSelectionSet
Dim gpCode(0 To 1) As Integer
Dim dataValue(0 To 1) As Variant
Dim groupCode, dataCode As Variant
SelectionDelete nameSBR
gpCode(0) = 0: dataValue(0) = "LWPolyline"
gpCode(1) = 8: dataValue(1) = "LO"
groupCode = gpCode
dataCode = dataValue
Set objSSLocal = ThisDrawing.SelectionSets.Add(nameSBR)
objSSLocal.Select acSelectionSetAll, , , groupCode, dataValue
Set SelectPolylineAll = objSSLocal
End Function
Function NumPointNewPL(LocalPlineObj As AcadLWPolyline) As Integer
Dim Coord As Variant
Dim LenPL As Double
NumPointNewPL = 0
Coord = LocalPlineObj.Coordinates
For i = 1 To (UBound(LocalPlineObj.Coordinates) - 1) / 2
'Считывание координат вершин исходной Полинии
LenPL = Sqr((Coord(2 * i - 2) - Coord(2 * i)) ^ 2 + (Coord(2 * i - 1) - Coord(2 * i + 1)) ^ 2)
NumPointNewPL = NumPointNewPL + LenPL \ Step + 1
Next i
End Function
Public Sub CalculateNewPointPolyLine()
Dim SizePL As Integer
Dim LenPL As Double
Dim AngleLine As Double
Dim StartpointGor(0 To 2) As Double
Dim EndpointGor(0 To 2) As Double
Dim NewPointsPL(0 To 1) As Double
Dim SelectName As String
Dim PointPL() As Double
Dim Coord As Variant
Dim objSSLocal As AcadSelectionSet
'Зачистка выборок
SelectionDelete "N1"
SelectName = "N1"
ThisDrawing.Utility.Prompt "Выбирете полилинию трассы для трассы"
Set objSS = ThisDrawing.SelectionSets.Add(SelectName)
objSS.SelectOnScreen
Set plineObj = objSS.Item(0)
SizePL = NumPointNewPL(plineObj)
ReDim PointPL(2 * SizePL + 1)
k = 0
Coord = plineObj.Coordinates
'Расчет точек в новой полилинии
For i = 1 To (UBound(plineObj.Coordinates) - 1) / 2
'Создани линий по плану полилинии для определения угла AngleLine
StartpointGor(0) = Coord(2 * i - 2)
StartpointGor(1) = Coord(2 * i - 1)
EndpointGor(0) = Coord(2 * i)
EndpointGor(1) = Coord(2 * i + 1)
LenPL = Sqr((Coord(2 * i - 2) - Coord(2 * i)) ^ 2 + (Coord(2 * i - 1) - Coord(2 * i + 1)) ^ 2)
Set lineObj = ThisDrawing.ModelSpace.AddLine(StartpointGor, EndpointGor)
AngleLine = lineObj.Angle
'Удаление линий по плану полилинии для определения угла AngleLine
lineObj.Delete
'Расчет координат
For j = 0 To LenPL \ Step
PointPL(k) = StartpointGor(0) + j * Step * Cos(AngleLine) 'Координты X
PointPL(k + 1) = StartpointGor(1) + j * Step * Sin(AngleLine) 'Координты Y
k = k + 2
Next j
Next i
PointPL(2 * SizePL) = EndpointGor(0)
PointPL(2 * SizePL + 1) = EndpointGor(1)
Set plineObj = ThisDrawing.ModelSpace.AddLightWeightPolyline(PointPL)
End Sub
Function NCount() As Integer 'Расчет числа заполненых строк
Set objExcel = GetObject(, "Excel.Application")
objExcel.Worksheets("Poperechnik").Activate
objExcel.Worksheets("Poperechnik").Select
NCount = 0
i = 5
Do While objExcel.Worksheets("Poperechnik").Cells(i, a12) <> ""
NCount = NCount + 1
i = i + 1
Loop
End Function
Public Sub SortCoordinate()
Dim VarLocal0, VarLocal1, VarLocal2 As Double
Dim Min As Integer
Dim count As Integer 'Ограничитель циклов
Set objExcel = GetObject(, "Excel.Application")
objExcel.Worksheets("Poperechnik").Activate
objExcel.Worksheets("Poperechnik").Select
For k = BeginRow To NCount + BeginRow
count = a14
For i = a14 To a14 + A * 3 Step 3
If objExcel.Worksheets("Poperechnik").Cells(k, i) <> "" Then
VarLocal0 = objExcel.Worksheets("Poperechnik").Cells(k, i)
For j = count To a14 + A * 3 Step 3
If objExcel.Worksheets("Poperechnik").Cells(k, j) <> "" Then
If VarLocal0 > objExcel.Worksheets("Poperechnik").Cells(k, j) Then
VarLocal0 = objExcel.Worksheets("Poperechnik").Cells(k, j)
Min = j
End If
Else
Exit For
End If
Next j
If Min <> 0 Then
VarLocal1 = objExcel.Worksheets("Poperechnik").Cells(k, Min + 1)
VarLocal2 = objExcel.Worksheets("Poperechnik").Cells(k, Min + 2)
objExcel.Worksheets("Poperechnik").Cells(k, Min) = objExcel.Worksheets("Poperechnik").Cells(k, i)
objExcel.Worksheets("Poperechnik").Cells(k, Min + 1) = objExcel.Worksheets("Poperechnik").Cells(k, i + 1)
objExcel.Worksheets("Poperechnik").Cells(k, Min + 2) = objExcel.Worksheets("Poperechnik").Cells(k, i + 2)
objExcel.Worksheets("Poperechnik").Cells(k, i) = VarLocal0
objExcel.Worksheets("Poperechnik").Cells(k, i + 1) = VarLocal1
objExcel.Worksheets("Poperechnik").Cells(k, i + 2) = VarLocal2
Min = 0
End If
Else
Exit For
End If
count = count + 3
Next i
Next k
End Sub
Public Sub CalculateUklonGorizont()
Dim LenPoint As Double
Dim StartpointGor(0 To 2) As Double
Dim EndpointGor(0 To 2) As Double
Dim Uklon As Double
Set objExcel = GetObject(, "Excel.Application")
objExcel.Worksheets("Poperechnik").Activate
objExcel.Worksheets("Poperechnik").Select
Uklon = 0
For i = BeginRow To NCount + BeginRow - 1
If objExcel.Worksheets("Poperechnik").Cells(i, a14) <> "" Then
For j = a14 To a14 + A * 3 Step 3
If objExcel.Worksheets("Poperechnik").Cells(i, j + 3) <> "" Then
StartpointGor(0) = objExcel.Worksheets("Poperechnik").Cells(i, j)
StartpointGor(1) = objExcel.Worksheets("Poperechnik").Cells(i, j + 1)
StartpointGor(2) = objExcel.Worksheets("Poperechnik").Cells(i, j + 2)
EndpointGor(0) = objExcel.Worksheets("Poperechnik").Cells(i, j + 3)
EndpointGor(1) = objExcel.Worksheets("Poperechnik").Cells(i, j + 3 + 1)
EndpointGor(2) = objExcel.Worksheets("Poperechnik").Cells(i, j + 3 + 2)
LenPoint = Sqr((StartpointGor(0) - EndpointGor(0)) ^ 2 + (StartpointGor(1) - EndpointGor(1)) ^ 2)
If LenPoint <> 0 Then
If Abs(Uklon) < Abs(Round(Atn((EndpointGor(2) - StartpointGor(2)) / LenPoint) * 180 / PI, 1)) Then
Uklon = Abs(Round(Atn((EndpointGor(2) - StartpointGor(2)) / LenPoint) * 180 / PI, 2))
End If
End If
Else
Exit For
End If
Next j
End If
objExcel.Worksheets("Poperechnik").Cells(i, 7) = Uklon
Uklon = 0
Next i
End Sub
Public Sub CalculatePolok()
Dim Angle As Double
Set objExcel = GetObject(, "Excel.Application")
objExcel.Worksheets("Poperechnik").Activate
objExcel.Worksheets("Poperechnik").Select
For k = BeginRow To NCount + BeginRow
Angle = TypePolkaSrezka(Abs(objExcel.Worksheets("Poperechnik").Cells(k, 7)), 5)
If TypePolkaSrezka(Abs(objExcel.Worksheets("Poperechnik").Cells(k, 7)), 5) <> 0 Then
objExcel.Worksheets("Poperechnik").Cells(k, 9) = Angle
End If
Next k
End Sub
Public Sub RazmetkaPolokDim()
Dim Polka1, Polka2 As Double
Dim mark As Long
Dim PointDim1(0 To 2) As Double
Dim PointDim2(0 To 2) As Double
Dim Location(0 To 2) As Double
PreparationLayers
ThisDrawing.ActiveLayer = ThisDrawing.Layers.Item("_ЛО_Размеры")
Set objExcel = GetObject(, "Excel.Application")
objExcel.Worksheets("Poperechnik").Activate
objExcel.Worksheets("Poperechnik").Select
For k = BeginRow To NCount + BeginRow - 1
Polka1 = objExcel.Worksheets("Poperechnik").Cells(k, a9)
Polka2 = objExcel.Worksheets("Poperechnik").Cells(k + 1, a9)
If Polka1 = 0 And Polka2 <> 0 Then
PointDim1(0) = objExcel.Worksheets("Poperechnik").Cells(k + 1, a12)
PointDim1(1) = objExcel.Worksheets("Poperechnik").Cells(k + 1, a13)
PointDim1(2) = 0
Location(0) = objExcel.Worksheets("Poperechnik").Cells(k, a12)
Location(1) = objExcel.Worksheets("Poperechnik").Cells(k, a13) - 300
Location(2) = 0
End If
If Polka1 <> 0 And Polka2 <> 0 And Polka1 <> Polka2 Then
PointDim2(0) = objExcel.Worksheets("Poperechnik").Cells(k + 1, a12)
PointDim2(1) = objExcel.Worksheets("Poperechnik").Cells(k + 1, a13)
PointDim2(2) = 0
Set dimObj = ThisDrawing.ModelSpace.AddDimAligned(PointDim1, PointDim2, Location)
dimObj.TextColor = acCyan
dimObj.TextOverride = "Тип полки по СПЛИТ " + CStr(Polka1)
End If
If Polka1 <> 0 And Polka2 <> 0 And Polka1 <> Polka2 Then
PointDim1(0) = objExcel.Worksheets("Poperechnik").Cells(k + 1, a12)
PointDim1(1) = objExcel.Worksheets("Poperechnik").Cells(k + 1, a13)
PointDim1(2) = 0
Location(0) = objExcel.Worksheets("Poperechnik").Cells(k, a12)
Location(1) = objExcel.Worksheets("Poperechnik").Cells(k, a13) - 300
Location(2) = 0
End If
If Polka1 <> 0 And Polka2 = 0 Then
PointDim2(0) = objExcel.Worksheets("Poperechnik").Cells(k + 1, a12)
PointDim2(1) = objExcel.Worksheets("Poperechnik").Cells(k + 1, a13)
PointDim2(2) = 0
Set dimObj = ThisDrawing.ModelSpace.AddDimAligned(PointDim1, PointDim2, Location)
dimObj.TextColor = acCyan
dimObj.TextOverride = "Тип полки по СПЛИТ " + CStr(Polka1)
End If
Next k
End Sub
Function TypePolkaSrezka(AlfaPop As Double, AlfaProd) As Double
If AlfaProd >= 18 Then
TypePolkaSrezka = 3.1
Else
If AlfaPop >= 18 Then
TypePolkaSrezka = 3.1
Else
If AlfaProd < 15 Then
If AlfaPop >= 8 And AlfaPop < 12 Then TypePolkaSrezka = 1.1
If AlfaPop >= 12 And AlfaPop < 18 Then TypePolkaSrezka = 2.1
End If
If AlfaProd >= 15 Then
If AlfaPop >= 8 And AlfaPop < 12 Then TypePolkaSrezka = 1.2
If AlfaPop >= 12 And AlfaPop < 18 Then TypePolkaSrezka = 2.2
End If
End If
End If
End Function
Function TypePolkaSrezkaText(AlfaPop As Double, AlfaProd) As String
Dim Var As Variant
'Варианты полок срезок при продолльном уклоне менее 15 град.
If AlfaProd < 15 Then
'If AlfaPop < 8 Then TypePolkaSrezka = "Не требуется срезок и полок"
If AlfaPop >= 8 And AlfaPop < 12 Then TypePolkaSrezka = "Полка тип " + "" + "Попер.А=" + CStr(AlfaPop) + "град." + " " + "Прод.А=" + CStr(AlfaProd) + "град."
If AlfaPop >= 12 And AlfaPop < 18 Then TypePolkaSrezka = "Полка II тип I. " + "Попер.А=" + CStr(AlfaPop) + "град." + " " + "Прод.А=" + CStr(AlfaProd) + "град."
If AlfaPop >= 18 Then TypePolkaSrezka = "Срезка до 15 град. " + "Попер.А=" + CStr(AlfaPop) + "град." + " " + "Прод.А=" + CStr(AlfaProd) + "град."
End If
'Варианты полок срезок при продолльном уклоне более 15 град.
If AlfaProd >= 15 Then
If AlfaPop < 8 Then TypePolkaSrezka = "Срезка. " + "Попер.А=" + AlfaPop + "град." + " " + "Прод.А=" + AlfaProd + "град."
If AlfaPop >= 8 And AlfaPop < 12 Then TypePolkaSrezka = "Полка I тип II. " + "Попер.А=" + AlfaPop + "град." + " " + "Прод.А=" + AlfaProd + "град."
If AlfaPop >= 12 And AlfaPop < 18 Then TypePolkaSrezka = "Полка II тип II. " + "Попер.А=" + AlfaPop + "град." + " " + "Прод.А=" + AlfaProd + "град."
If AlfaPop >= 18 Then TypePolkaSrezka = "Срезка. " + "Попер.А=" + AlfaPop + "град." + " " + "Прод.А=" + AlfaProd + "град."
End If
End Function
Private Sub NumberPiket()
Dim VarStr As Variant
For k = BeginRow To NCount + BeginRow - 1
objExcel.Worksheets("Poperechnik").Cells(k, a2) = k + 1 - BeginRow
objExcel.Worksheets("Poperechnik").Cells(k, a3) = "ПК"
VarStr = Split(BeginPiket, "+")
objExcel.Worksheets("Poperechnik").Cells(k, a4) = (VarStr(0) * 100 + VarStr(1) + (k - BeginRow) * Step) \ StandartPiket
objExcel.Worksheets("Poperechnik").Cells(k, a5) = "+"
objExcel.Worksheets("Poperechnik").Cells(k, a6) = (VarStr(0) * 100 + VarStr(1) + (k - BeginRow) * Step) Mod StandartPiket
Next k
End SubPS: не понял как сюда подцепить файлы...но кому надо могу выслать исходники.
