ccna
Junior Member | Редактировать | Профиль | Сообщение | Цитировать | Сообщить модератору
Добрый день, друзья!
Есть документ xls с настроенным макросом. В этой таблице формируется отчет поэтажного плана из графической программы. В настоящий момент таблица формирует отчет только по одному этажу, даже если выделены, скажем, с 1 по 17. То есть, действует это ограничение.
Задача: нужно, чтоб формировался отчет по всем этажам. То есть, устранить это ограничение.
Подскажите, как это сделать?
Заранее спасибо!
Вот содержание таблицы:
' PlanCAD Automation Sample
' Copyright (C) 2010 by Consistent Software, Inc.
Option Explicit
' вызывается из Планкад
Sub PT_RunFunc(Objects As PTObjects, ptApp As PTApplication)
Dim floor As PTFloor
If Objects.Count > 0 Then
Dim obj As IPTObject
For Each obj In Objects
If obj.Type = ptObjTypeFloor Then
Set floor = obj
Exit For
End If
Next
End If
If Not floor Is Nothing Then
UpdateReport floor, ptApp
Else
MsgBox "Неверные данные!"
End If
End Sub
' обновить отчет по этажу
Sub Update()
' получить модель плана
Dim ptApp As PTApplication
Set ptApp = GetPlanModel
' получить этаж по номеру
Dim floor As PTFloor
Set floor = GetFloorById
If floor Is Nothing Then
MsgBox "Нет этажа с таким номером!"
Exit Sub
End If
' обновить
Sheets("Экспликация этажа").Select
UpdateReport floor, ptApp
End Sub
' обновить отчет по этажу
Sub UpdateReport(floor As PTFloor, ptApp As PTApplication)
' площади этажа
Dim totalArea As Double, flatArea As Double
Dim livingArea As Double, subsdArea As Double, balcArea As Double
totalArea = flatArea = livingArea = subsdArea = balcArea = 0#
' заполняем данные по помещениям и входящим в них комнатам
Dim row As Integer
row = 12
Dim obj As IPTObject
For Each obj In floor.Objects
' квартира
If obj.Type = ptObjTypeFlat Then
UpdateFlat obj, floor, totalArea, flatArea, livingArea, subsdArea, balcArea, row
End If
Next
' вспомогательные чп (не входящие в помещения)
UpdateRooms floor.Objects, Nothing, floor, totalArea, flatArea, livingArea, subsdArea, balcArea, row
' èòîãî
Cells(row, 1).Formula = ""
Cells(row, 2).Formula = floor.floorId
Cells(row, 3).Formula = ""
Cells(row, 4).Formula = ""
Cells(row, 5).Formula = ""
Cells(row, 6).Formula = ""
' площадь с учетом неотапливаемых ÷ï
If totalArea > 0 Then Cells(row, 7).Formula = totalArea Else Cells(row, 7).Formula = ""
' общая площадь
If flatArea > 0 Then Cells(row, 8).Formula = flatArea Else Cells(row, 8).Formula = ""
' жилая
If livingArea > 0 Then Cells(row, 9).Formula = livingArea Else Cells(row, 9).Formula = ""
' подсобная
If subsdArea > 0 Then Cells(row, 10).Formula = subsdArea Else Cells(row, 10).Formula = ""
' лоджий, балконов
If balcArea > 0 Then Cells(row, 11).Formula = balcArea Else Cells(row, 11).Formula = ""
' высота
Cells(row, 12).Formula = floor.Height
Cells(row, 13).Formula = ""
Cells(row, 14).Formula = ""
row = row + 1
' clear last records
While Cells(row, 2).Formula <> "" Or Cells(row, 3).Formula <> "" Or Cells(row, 4).Formula <> ""
Range(Cells(row, 1), Cells(row, 14)).ClearContents
row = row + 1
Wend
End Sub
' обновить информацию о помещении
Sub UpdateFlat(flat As PTFlat, floor As PTFloor, ByRef totalArea As Double, ByRef flatArea As Double, ByRef livingArea As Double, ByRef subsdArea As Double, ByRef balcArea As Double, ByRef row As Integer)
' части помещения
Dim flatTotalArea As Double, flatFlatArea As Double
Dim flatLivingArea As Double, flatSubsdArea As Double, flatBalcArea As Double
flatTotalArea = flatFlatArea = flatLivingArea = flatSubsdArea = flatBalcArea = 0#
UpdateRooms flat.Objects, flat, floor, flatTotalArea, flatFlatArea, flatLivingArea, flatSubsdArea, flatBalcArea, row
' итого
Cells(row, 1).Formula = ""
Cells(row, 2).Formula = floor.floorId
Cells(row, 3).Formula = flat.FlatId
Cells(row, 4).Formula = ""
Cells(row, 5).Formula = ""
Cells(row, 6).Formula = ""
' площадь с учетом неотапливаемых÷ï
If flatTotalArea > 0 Then Cells(row, 7).Formula = flatTotalArea Else Cells(row, 7).Formula = ""
'общая площадь
If flatFlatArea > 0 Then Cells(row, 8).Formula = flatFlatArea Else Cells(row, 8).Formula = ""
' жилая
If flatLivingArea > 0 Then Cells(row, 9).Formula = flatLivingArea Else Cells(row, 9).Formula = ""
' подсобная
If flatSubsdArea > 0 Then Cells(row, 10).Formula = flatSubsdArea Else Cells(row, 10).Formula = ""
' лоджий, балконов
If flatBalcArea > 0 Then Cells(row, 11).Formula = flatBalcArea Else Cells(row, 11).Formula = ""
' высота
Cells(row, 12).Formula = flat.Height
Cells(row, 13).Formula = ""
Cells(row, 14).Formula = ""
totalArea = totalArea + flatTotalArea
flatArea = flatArea + flatFlatArea
livingArea = livingArea + flatLivingArea
subsdArea = subsdArea + flatSubsdArea
balcArea = balcArea + flatBalcArea
row = row + 1
End Sub
' обновить части помещения
Sub UpdateRooms(rooms As PTObjects, flat As PTFlat, floor As PTFloor, ByRef totalArea As Double, ByRef flatArea As Double, ByRef livingArea As Double, ByRef subsdArea As Double, ByRef balcArea As Double, ByRef row As Integer)
Dim obj As IPTObject
For Each obj In rooms
If obj.Type = ptObjTypeRoom Then
Dim room As PTRoom
Set room = obj
If (flat Is Nothing) = (room.flat Is Nothing) Then
' литера
Cells(row, 1).Formula = room.Litera
' этаж
If Not floor Is Nothing Then Cells(row, 2).Formula = floor.floorId Else Cells(row, 2).Formula = ""
' помещение
If Not flat Is Nothing Then Cells(row, 3).Formula = flat.FlatId Else Cells(row, 3).Formula = ""
' номер ÷ï
Cells(row, 4).Formula = room.RoomId
' назначение
Cells(row, 5).Formula = room.Description
' формула
Cells(row, 6).Formula = room.area.Formula
' ïëîùàäü ÷ï
Dim roomArea As Double
roomArea = FormatNumber(room.area, 1)
'площадь с учетом неотапливаемых чп
Dim area As Double
area = FormatNumber(roomArea * room.AreaFactor, 1)
totalArea = totalArea + area
If area > 0 Then Cells(row, 7).Formula = area Else Cells(row, 7).Formula = ""
'общая площадь
If room.AreaCategory = ptAreaCategoryLiving Or room.AreaCategory = ptAreaCategorySubsidiary Then
area = FormatNumber(roomArea * room.AreaFactor, 1)
flatArea = flatArea + area
Else
area = 0#
End If
If area > 0 Then Cells(row, 8).Formula = area Else Cells(row, 8).Formula = ""
' жилая
If room.AreaCategory = ptAreaCategoryLiving Then
area = roomArea
livingArea = livingArea + area
Else
area = 0#
End If
If area > 0 Then Cells(row, 9).Formula = area Else Cells(row, 9).Formula = ""
' подсобная
If room.AreaCategory = ptAreaCategorySubsidiary Then
area = FormatNumber(roomArea * room.AreaFactor, 1)
subsdArea = subsdArea + area
Else
area = 0#
End If
If area > 0 Then Cells(row, 10).Formula = area Else Cells(row, 10).Formula = ""
' лоджий, балконов
If room.AreaCategory = ptAreaCategoryCold Then
area = FormatNumber(room.area * room.AreaFactor, 1)
balcArea = balcArea + area
Else
area = 0#
End If
If area > 0 Then Cells(row, 11).Formula = area Else Cells(row, 11).Formula = ""
' высота
Cells(row, 12).Formula = room.Height
Cells(row, 13).Formula = ""
Cells(row, 14).Formula = ""
row = row + 1
End If
End If
Next
End Sub
' возвращает этаж по номеру
Function GetFloorById(sFloorId As String, ptApp As PTApplication) As PTFloor
Set GetFloorById = Nothing
Dim floor As PTFloor
For Each floor In ptApp.ObjectsByType(ptObjTypeFloor)
If floor.floorId = sFloorId Then
Set GetFloorById = floor
Exit For
End If
Next
End Function
' returns the plan model
Function GetPlanModel() As PTApplication
Dim app
Set app = CreateObject("PlanCad.Application")
app.Visible = True
Set GetPlanModel = app.Documents.ActivePlanModel
End Function |
Только на Вас и надежда
