Перейти из форума на сайт.

НовостиФайловые архивы
ПоискАктивные темыТоп лист
ПравилаКто в on-line?
Вход Забыли пароль? Первый раз на этом сайте? Регистрация
Компьютерный форум Ru.Board » Компьютеры » Прикладное программирование » Exel VBA

Модерирует : ShIvADeSt

articlebot (25-11-2014 06:05): дубль - Excel VBA (часть 3).  Версия для печати • ПодписатьсяДобавить в закладки

   

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 = ""
  ' площадь с учетом неотапливаемых&#247;&#239;
  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 = ""
        ' номер &#247;&#239;
        Cells(row, 4).Formula = room.RoomId
        ' назначение
        Cells(row, 5).Formula = room.Description
        ' формула
        Cells(row, 6).Formula = room.area.Formula
        ' &#239;&#235;&#238;&#249;&#224;&#228;&#252; &#247;&#239;
        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

Всего записей: 182 | Зарегистр. 12-11-2005 | Отправлено: 10:51 14-11-2014
Mavrikii

Platinum Member
Редактировать | Профиль | Сообщение | Цитировать | Сообщить модератору
ccna
Excel VBA (часть 3)

Всего записей: 11114 | Зарегистр. 20-09-2014 | Отправлено: 10:56 14-11-2014
   

Компьютерный форум Ru.Board » Компьютеры » Прикладное программирование » Exel VBA
articlebot (25-11-2014 06:05): дубль - Excel VBA (часть 3).


Реклама на форуме Ru.Board.

Powered by Ikonboard "v2.1.7b" © 2000 Ikonboard.com
Modified by Ru.Board
© Ru.Board 2000-2020

BitCoin: 1NGG1chHtUvrtEqjeerQCKDMUi6S6CG4iC

Рейтинг.ru