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 |