Hello, I have a problem that when creating a table using my VBA code, depending on the scale of the file, the created table is generated completely deformed, and for me this doesn't make sense because for me the table being generated at a different scale was expected, but completely deformed was a terrible surprise, I managed to get around the problem by asking the user if he wants to use a scale multiplication factor of 20 which strangely ends up leaving the table in the desired format.
Sub CONT_BOX_ESGOTO_COM_TAB()
Dim AnswerYes As String 'CAIXA DE SELEÇÃO Y/N
Dim BLOCK As AcadBlockReference 'BLOCO DE REFERENCIA
Dim CodX As Double 'CORDENADA X DO BLOCO
Dim CodY As Double 'CORDENADA Y DO BLOCO
Dim CodZ As Double 'CORDENADA Z DO BLOCO
Dim col As Double 'NUMERO DE COLUNAS
Dim D1 As Double 'ALTURA DA TABELA
Dim D2 As Double 'LARGURA DA TABELA
Dim DimeA As Single 'METADE DO VALOR DA DIMENSÃO A
Dim DimeB As Single 'METADE DO VALOR DA DIMENSÃO A
Dim filePath As String 'LOCAL DO ARQUIVO DO BLOCO DINAMICO DE REFERENCIA
Dim FilterData(0 To 1) As Variant 'cria a variavel filtro data
Dim FilterType(0 To 1) As Integer 'cria a variavel filtro type
Dim key As Double 'CHAVE DE ETAPAS DE MONTAGEM DA TABELA
Dim lin As Double 'LINHA DAS TABELAS
Dim NAME As String 'NOME EFETIVO DO BLOCO
Dim NumNCE As Single 'ATRIBUTO DE IDENTIFICAÇÃO
Dim NumNDC As String 'ATRIBUTO NIVEL DO PISO
Dim NumNDT As String 'ATRIBUTO ALTURA DA TAMPA
Dim NumNTE As String 'ATRIBUTO NIVEL DA LAJE
Dim props() As AcadDynamicBlockReferenceProperty 'PROPRIEDADES DE UM BLOCO DINAMICO
Dim PV As String 'NIVEL DA LAJE
Dim Ref(0 To 2) As Double 'PONTO DE INSERÇAO DO BLOCO
Dim ROT As Double 'ROTAÇÃO DO BLOCO ANALISADO
Dim SBX As Double 'ESCALA X DO BLOCO ANALISADO
Dim SBY As Double 'ESCALA Y DO BLOCO ANALISADO
Dim SBZ As Double 'ESCALA Z DO BLOCO ANALISADO
Dim SCX As Double 'ESCALA X DA TABELA ANALISADO
Dim SCY As Double 'ESCALA Y DA TABELA ANALISADO
Dim SCZ As Double 'ESCALA Z DA TABELA ANALISADO
Dim TagBl As String 'TAG DE IDENTIFICAÇÃO DOS BLOCOS
Dim TagShf As String 'TAG DE NUMERAÇÃO DOS BLOCOS
Dim TColsEnt As AcadTable 'TABELA
Dim Verde As AcadAcCmColor 'COR VERDE
'VERIFICAR O ESQUEMA DE ESCALA DA TABELA
'VERIFICAR O AZIMUTE
filePath = "C:\Users\victor.ciotti\Desktop\blocos caixa de esgoto\SEGUNDA GERAÇÃO\refbox.dwg" '"local provisório"
col = 9 'NUMERO DE COLUNAS
lin = 4 'NUMERO DE LINHAS
key = 0 'CHAVE DE ACESSO
D1 = 0.07 'ALTURA DA TABELA
D2 = 0.8 'LARGURA DA TABELA
TH = 0.105 'TAMANHO DA LETRA
RC = 0.36 'LARGURA DA CÉLULA
MC = 3 'MARGEM DA CÉLULA
'ARMAZENA ESTADO E CONFIGUAÇÃO ANTERIORES DO OSNAP, ATIVA O OSNAP CASO ESTEJA DESATIVADO
'E SETA PARA NEA
FlagOsnap = ThisDrawing.ObjectSnapMode
If FlagOsnap Then
ThisDrawing.ObjectSnapMode = True
End If
'INPUTBOX PARA O USUARIO
NumNCE = InputBox("Entre o numero inicial para numeração de caixas de esgoto", "Numero de caixas de esgoto") 'PARA O NUMERO
TagBl = InputBox("Defina o código inicial da tag (3 caracteres)", "Tag do bloco") 'PARA O MINOMONICO
AnswerYes = MsgBox("Você deseja aplicar o fator de 20 a escala para ajustar qualquer distorção?", vbQuestion + vbYesNo, "Resposta do Usuário") ' PERGUNTA AO USUARIO DA ATIVAÇÃO
'DO FATOR DE ATI DEFORMAÇÃO
If AnswerYes = vbYes Then
FS = 20 ' FATOR ANTI DEFORMAÇÃO ATIVO
Else
FS = 1 ' FATOR ANTI DEFORMAÇÃO DESATIVO
End If
'VERIFICA SELECTION SET JA EXISTE, E APAGA EM CASO AFIRMATIVO
For Each SSet In ThisDrawing.SelectionSets
If SSet.NAME = "CDI" Then
ThisDrawing.SelectionSets.Item("CDI").Delete 'elemina outro selection set chamado cdi
Exit For
End If
Next SSet
'CRIA NOVO SELECTION SET PARA CAIXAS DE ESGOTO E POSTOS DE VISITA
Set SelCDI = ThisDrawing.SelectionSets.Add("CDI") 'seta um selection set chamado cdi
Set BlkCol = ThisDrawing.Blocks 'setar o bloco a ser modificado
'FILTRA E SELECIONA INSERÇÕES DE BLOCOS DO DESENHO
FilterType(0) = 0
FilterData(0) = "Insert" 'BLOCOS INSERIDOS
FilterType(1) = 8
FilterData(1) = "AHD" 'SELEÇÃO DO LAYER
'CICLA AS ENTIDADES SELECIONADAS E VERIFICA SE É UMA INSERÇÃO DE BLOCOS PONTO DE VISTA CIRCULO, QUADRADO E CAIXAS
'EM CASO AFIRMATIVO ARMAZENA AS TAGS DO BLOCO E O NUMERO DA ENTIDADE
FimSel = 1 ' chave para entrar no while
'FUNÇÃO DE EXTRAÇÃO DO BLOCO
Do While FimSel <> 0
SelCDI.SelectOnScreen FilterType, FilterData 'cria o selection set chamado cdi com um filtro de busca 0,
If key = 0 Then 'CHAVE DE VERIFICAÇÃO PRIMEIRA ATIVAÇAO
PC = ThisDrawing.Utility.GetPoint(, "selecione ponto cárdial") 'SELECIONA O PONTO CARDIAL
Else
End If
key = key + 1 'CONTADOR PARA MUDAR O VALOR DA CHAVE
If SelCDI.Count = 1 Then 'se tiver uma seleção entra no if
'EXTRAÇÃO DE INFORMAÇOES DOS BLOCOS
Set BlkEnt = SelCDI(0) 'se a caixa de esgoto estiver no selection set
AtribCol = BlkEnt.GetAttributes 'pega o atributo da caixa de esgotoBlockReference.InsertionPoint
props = BlkEnt.GetDynamicBlockProperties 'ADQUIRI PROPRIEDADES DOS BLOCOS
X = BlkEnt.insertionPoint 'LOCAL DE INSERÇÃO DO BLOCO
NAME = BlkEnt.EffectiveName 'NOME DO BLOCO
NumAtribs = UBoundAtributes 'define o valor do atributo
NumAtribs = UBound(AtribCol) + 1 'acrescenta o valor ao atributo da caixa de esgoto
NumNDC = AtribCol(2).TextString 'EXTRAI ATRIBUTO DA PROFUNDIDADE DO PISO
If NAME = "-pvqua" Or NAME = "-pvcir" Then 'SE FOR UM PONTO DE VISITA QUADRADO OU CIRCULAR
NumNTE = AtribCol(3).TextString 'EXTRAI VALOR DO TETO
PV = AtribCol(4).TextString 'EXTRAI VALOR DO AZIMUTE
Else
PV = AtribCol(3).TextString 'EXTRAI VALOR DO AZIMUTE
End If
'INUMERAÇÃO DOS BLOCOS E PRENCHIMENTO DA PRIMEIRA CÉLULA DA TABELA
If NumNCE < 10 Then 'SITUAÇÃO DE DE COLOCAR OU NÃO O ZERO
AtribCol(0).TextString = TagBl & "0" & NumNCE 're-escreve o valor do atributo NESSE CASO JUNTANDO O NUMERO E O CÓDIGO DEFENIDO PELO INPUTBOX E COLOCANDO O ZERO
Else
AtribCol(0).TextString = TagBl & NumNCE 're-escreve o valor do atributo NESSE CASO JUNTANDO O NUMERO E O CÓDIGO DEFENIDO PELO INPUTBOX
End If
'DEFINIÇÃO DE VALORES PARA O PRENCHIMENTO DA TABELA
NumNDT = AtribCol(1).TextString 'EXTRAI ATRIBUTO DA ALTURA DA TAMPA
CodX = Round(X(0), 2) 'EXTRAI CORDENADA X E ARREDONDADO
CodY = Round(X(1), 2) 'EXTRAI CORDENADA Y E ARREDONDADO
CodZ = Round(X(2), 2) 'EXTRAI CORDENADA Z E ARREDONDADO
Application.Update 'ATUALIZA O DESENHO
NumNCE = NumNCE + 1 'CONTADOR NUMERO DE LINHAS
SelCDI.Clear 'LIMPA SELECTION SET
PtInsShf = BlkEnt.insertionPoint 'PONTO DE INSERÇÃO DO BLOCO A SER ANALISADO
'DEFINIÇÃO DE CORES DAS TABELAS
Set Verd = AcadApplication.GetInterfaceObject("AutoCAD.acCmColor.20") 'DEFINIÇÃO DE COR PARA A TABELA VERDE
Set Cyan = AcadApplication.GetInterfaceObject("AutoCAD.acCmColor.20") 'DEFINIÇÃO DE COR PARA A TABELA CYAN
Set Amar = AcadApplication.GetInterfaceObject("AutoCAD.acCmColor.20") 'DEFINIÇÃO DE COR PARA A TABELA AMARELO
Set Bran = AcadApplication.GetInterfaceObject("AutoCAD.acCmColor.20") 'DEFINIÇÃO DE COR PARA A TABELA BRANCO
Verd.ColorIndex = acGreen 'DEFINIÇÃO DE COR PARA A TABELA VERDE
Cyan.ColorIndex = acCyan 'DEFINIÇÃO DE COR PARA A TABELA CYAN
Amar.ColorIndex = acYellow 'DEFINIÇÃO DE COR PARA A TABELA AMARELO
Bran.ColorIndex = acWhite 'DEFINIÇÃO DE COR PARA A TABELA BRANCO
'DEFINIÇÃO DE DIMENSÃO A E B CADA BLOCO TEM SUAS VARIAÇÕES NECESSITANDO ESSA SEPARAÇÃO
If NAME = "-pvqua" Then 'NA SITUAÇÃO DE PODTO DE VISITA QUADRADA
DimeA = Round(props(1).Value, 2) 'DIMENSÃO 1 POSTO DE VISITA QUADRADO
DimeB = Round(props(3).Value, 2) 'DIMENSÃO 2 POSTO DE VISITA QUADRADO
ElseIf NAME = "-pvcir" Then 'NA SITUAÇÃO DE PODTO DE VISITA CIRCULAR
DimeA = Round(props(0).Value, 2) 'DIMENSÃO 1 POSTO DE VISITA CIRCULAR
DimeB = Round(props(2).Value, 2) 'DIMENSÃO 2 POSTO DE VISITA CIRCULAR
Else 'NA SITUAÇÃO DE SAR UMA CAIXA DE ESGOTO
DimeA = Round(props(0).Value + props(2).Value, 2) 'DIMENSÃO 1 CAIXA DE ESGOTO
DimeB = Round(props(4).Value + props(8).Value, 2) 'DIMENSÃO 2 CAIXA DE ESGOTO
End If
'ATUALIZAÇÃO E PRENCHIMENTO DE NOVAS LINHAS
If key > 1 Then 'CHAVE NESSA SITUAÇÃO QUANDO NÃO É A PRIMEIRA VERSÃO
lin = lin + 1 'CONTADOR DE LINHAS
MX = CodX - PC(0) 'EXTRAÇÃO DE CORDENADAS PARA CALCULO VERTICE X DO AZIMUTE
MY = CodY - PC(1) 'EXTRAÇÃO DE CORDENADAS PARA CALCULO VERTICE Y DO AZIMUTE
MZ = CosZ - PC(2) 'EXTRAÇÃO DE CORDENADAS PARA CALCULO VERTICE Z DO AZIMUTE
HIP = Atn(MY / MX) 'CALCULO DA HIPOTENUSA DO AZIMUTE
ANGEND = Round((HIP * 180) / 3.xxx-xxxxxxxx, 2) 'CONVERSÃO DE RADIANUS PARA GRAUS
AtribCol(3).TextString = ANGEND 'INSERE O VALOR DO AZIMUTE
With TColsEnt
.InsertRows lin, TH * SCX, 1 'PONTO DE INSERÇÃO DA TABELA
.AllowManualHeights = True 'ALTURA DA LETRA MANUAL
Count = 0 'CONTADOR SIRCUNSTACIA ZERO PARA DEFINIÇÃO DAS LINHAS/CÉLULAS NOVAS
While Count < 9 'WHILE DE DEFINIÇÃO E PRENCHIMENTO DE CÉLULAS
.SetCellTextHeight lin - 1, Count, TH * SCX 'SETANDO TAMANHO DA LETRA DAS CÉLULAS
.SetCellTextStyle lin - 1, Count, "SIMPLEX" 'TIPO DE LINHA DAS CÉLULAS
.SetCellContentColor lin - 1, Count, Verd 'COR DAS LETRAS DAS CÉLULAS
.SetCellGridColor lin - 1, Count, AcCellEdgeMask.acBottomMask, Cyan 'LINHAS CYANS NA LATERAL DIREITA
.SetCellGridColor lin - 2, Count, AcCellEdgeMask.acBottomMask, Amar 'LINHAS CYANS NA LATERAL ESQUERDA
.SetCellAlignment lin - 1, Count, acMiddleRight 'CENTRALIZAÇÃO CENTRAL DIREITA DAS CÉLULAS
.SetCellGridColor lin - 1, Count, AcCellEdgeMask.acLeftMask, Verd 'COR DA LINHA D GRID
.SetMargin lin - 1, Count, acCellMarginRight, MC * SCX
Count = Count + 1
Wend
'DEFINIÇÃO DE CORES DO GRID PARA A TABELA
.SetCellGridColor lin - 1, 0, AcCellEdgeMask.acLeftMask, Cyan 'LINHA CYAN NO TOPO
.SetCellGridColor lin - 1, -1, AcCellEdgeMask.acRightMask, Cyan 'LINHA CYAN NA DIREITA
.SetCellAlignment lin - 1, 0, acMiddleCenter 'CENTRALIZAÇÃO CENTRAL CENTRAL DAS CÉLULAS
.SetRowHeight lin - 1, RC * SCX 'TAMANHO DO TEXTO DA CÉLULA
'PRENCHIMENTO DAS CELULAS DE TODAS AS COLUNAS DA RESPECTIVA LINHA
If NAME = "-pvqua" Then 'SITUAÇÃO POSTO DE VISITA QUADRADO
If NumNCE - 1 < 10 Then 'SITUAÇÃO DE DE COLOCAR OU NÃO O ZERO NA CÉLULA 1/9
.SetText lin - 1, 0, TagBl & "0" & NumNCE - 1 'COLOCAR ZERO
Else
.SetText lin - 1, 0, TagBl & NumNCE - 1 'NÃO COLOCAR O ZERO
End If
.SetText lin - 1, 1, NumNDT 'PRENCHE CÉLULA 2/9
.SetText lin - 1, 2, NumNDC 'PRENCHE CÉLULA 3/9
.SetText lin - 1, 3, PV 'PRENCHE CÉLULA 4/9
.SetText lin - 1, 4, DimeA 'PRENCHE CÉLULA 5/9
.SetText lin - 1, 5, DimeB 'PRENCHE CÉLULA 6/9
.SetText lin - 1, 6, CodX 'PRENCHE CÉLULA 7/9
.SetText lin - 1, 7, CodY 'PRENCHE CÉLULA 8/9
.SetText lin - 1, 8, ANGEND 'PRENCHE CÉLULA 9/9
ElseIf NAME = "-pvcir" Then 'SITUAÇÃO POSTO DE VISITA CIRCULAR
If NumNCE - 1 < 10 Then 'SITUAÇÃO DE DE COLOCAR OU NÃO O ZERO NA CÉLULA 1/9
.SetText lin - 1, 0, TagBl & "0" & NumNCE - 1 'COLOCAR ZERO
Else
.SetText lin - 1, 0, TagBl & NumNCE - 1 'NÃO COLOCAR O ZERO
End If
.SetText lin - 1, 1, NumNDT 'PRENCHE CÉLULA 2/9
.SetText lin - 1, 2, NumNDC 'PRENCHE CÉLULA 3/9
.SetText lin - 1, 3, PV 'PRENCHE CÉLULA 4/9
.SetText lin - 1, 4, DimeA * 2 'PRENCHE CÉLULA 5/9
.SetText lin - 1, 5, DimeB * 2 'PRENCHE CÉLULA 6/9
.SetText lin - 1, 6, CodX 'PRENCHE CÉLULA 7/9
.SetText lin - 1, 7, CodY 'PRENCHE CÉLULA 8/9
.SetText lin - 1, 8, ANGEND 'PRENCHE CÉLULA 9/9
Else ' SITUAÇÃO DA CAIXA DE ESGOTO
If NumNCE - 1 < 10 Then 'SITUAÇÃO DE DE COLOCAR OU NÃO O ZERO NA CÉLULA 1/9
.SetText lin - 1, 0, TagBl & "0" & NumNCE - 1 'COLOCAR ZERO
Else
.SetText lin - 1, 0, TagBl & NumNCE - 1 'NÃO COLOCAR O ZERO
End If
.SetText lin - 1, 1, NumNDT 'PRENCHE CÉLULA 2/9
.SetText lin - 1, 2, NumNDC 'PRENCHE CÉLULA 3/9
.SetText lin - 1, 3, "N/A" 'PRENCHE CÉLULA 4/9
.SetText lin - 1, 4, DimeA 'PRENCHE CÉLULA 5/9
.SetText lin - 1, 5, DimeB 'PRENCHE CÉLULA 6/9
.SetText lin - 1, 6, CodX 'PRENCHE CÉLULA 7/9
.SetText lin - 1, 7, CodY 'PRENCHE CÉLULA 8/9
.SetText lin - 1, 8, ANGEND 'PRENCHE CÉLULA 9/9
End If
TColsEnt.Update 'ATUALIZAR A TABELA
End With
Else
'DEFINIÇÃO DO PONTO DA INSERÇÃO DA TABELA E DEFINIÇÃO DE UM FATOR DE ESCALA
SP = ThisDrawing.Utility.GetPoint(, "selecione ponto de inserção da tabela") 'SELECIONA PONTO DE INSERÇÃO DA TABELA
SCX = BlkEnt.XScaleFactor * FS 'ESCALA X DO BLOCO----------------------------------------------------------------------------------------------------------------------------------
SCY = BlkEnt.YScaleFactor 'ESCALA Y DO BLOCO
SCZ = BlkEnt.ZScaleFactor 'ESCALA Z DO BLOCO
D1 = D1 * SCX
D2 = D2 * SCX
'FATOR DE MODIFICAÇÃO DE ESCALA DE BLOCO DE NOTAS E DEFINIÇÃO DE ROTAÇÃO
SBX = 1 * SCX 'FATOR DE ESCALA X DA TABELA
SBY = 1 * SCY 'FATOR DE ESCALA Y DA TABELA
SBZ = 1 * SCZ 'FATOR DE ESCALA Z DA TABELA
ROT = 0# 'ROTAÇÃO DA TABELA
'FATORES DE CALCULO DO AZIMUTE
MX = CodX - PC(0) 'DELTA X DO AZIMUTE
MY = CodY - PC(1) 'DELTA Y DO AZIMUTE
MZ = CosZ - PC(2) 'DELTA Z DO AZIMUTE
HIP = Atn(MY / MX) 'HIPOTENUSA DO AZIMUTE
ANGEND = Round((HIP * 180) / 3.xxx-xxxxxxxx, 2) 'CONVERTENDO A HIPOTENUSA DE RADIANUS PARA GRAUS
AtribCol(3).TextString = ANGEND
'FATORES DE CRIAÇÃO DA TABELA E DEFINIÇÃO DO CABEÇALHO
lin = 4 'LINHA INICIAL 4
AtribCol(0).Height = AtribCol(0).Height '* SCX 'VALOR DE ESCALA X DO BLOCO
Set TColsEnt = ThisDrawing.ModelSpace.AddTable(SP, lin, col, D1, D2) 'CRIAÇÃO DA TABELA
'Ref(0) = SP(0) + (D1 / 2) * SCX
Ref(0) = SP(0) + (D2 * 4.5) 'PONTO DE ISERÇÃO X DO BLOCO DE REFERENCIA
Ref(1) = SP(1) - (D1 * 36.4285714285714) ' PONTO DE ISERÇÃO Y DO BLOCO DE REFERENCIA
Ref(2) = SP(2) * SCX 'PONTO DE ISERÇÃO Z DO BLOCO DE REFERENCIA
Set BLOCK = ThisDrawing.ModelSpace.InsertBlock(Ref, filePath, SCX, SCX, SCX, ROT) 'SBX, SBY, SBZ, ROT) 'CRIAÇÃO DO BLOCO
With TColsEnt
'DEFINIÇÃO DE DIMENSÃO E CORES DAS PRIMEIRAS 4 LINHAS DAS TABELAS
.AllowManualHeights = True 'ALTURA DA LETRA MANUAL
.MergeCells 0, 0, 0, 0 'MESCLAGEM DE TODAS AS CÉLULAS DA LINHA 0
.SetRowHeight 0, 0.4 * SCX 'ALTURA DA LINHA ZERO
.SetCellContentColor 0, 0, Verd 'COR DO TEXTO DA CÉLULA
.SetCellTextHeight 0, 0, 0.131 * SCX 'ALTUAR TEXTO DA CÉLULA 0
.SetCellBackgroundColor 0, 0, Bran 'COR DE PRENCHIMENTO BRANCO DA CÉLULA ZERO
.MergeCells 1, 1, 0, 8 'MESCLAGEM DE TODAS AS CÉLULAS DA LINHA 1
.SetRowHeight 1, 4 * SCX 'ALTURA DA LINHA UM
.SetRowHeight 2, 0.839 * SCX 'ALTURA DA CÉLULA 2
.SetRowHeight 3, RC * SCX 'ALTURA DA CÉLULA 3
'DEFINIÇÃO E CRIAÇÃO DAS LINHAS 2 E 3 DE TODAS AS CÉLULAS
Count = 0 'SITUAÇÃO ZERO
While Count < 9
.SetCellTextHeight 2, Count, TH * SCX 'TAMANHO DA LETRA LINHA 2
.SetCellTextHeight 3, Count, TH * SCX 'TAMANHO DA LETRA LINHA 3
.SetCellAlignment 1, Count, acMiddleCenter 'CENTRALIZAÇÃO DA LINHA 1 CENTRO CENTRO
.SetCellAlignment 2, Count, acMiddleCenter 'CENTRALIZAÇÃO DA LINHA 10 CENTRO CENTRO
.SetCellContentColor 3, Count, Verd 'COR DO TEXTO DA LINHA 3
.SetCellContentColor 2, Count, Amar 'COR DAS LETRAS DAS CÉLULAS
.SetCellGridColor 0, Count, AcCellEdgeMask.acBottomMask, Verd 'COR DE UMA LINHA VERDE NO GRID
.SetCellGridColor NumCols, Count, AcCellEdgeMask.acBottomMask, Cyan 'LINHA DO GRID AZUL
.SetCellGridColor lin - 1, Count, AcCellEdgeMask.acBottomMask, Cyan 'LINHA DO GRID AZUL
.SetCellGridColor 1, Count, AcCellEdgeMask.acBottomMask, Cyan 'LINHA DO GRID AZUL
.SetCellGridColor 2, Count, AcCellEdgeMask.acBottomMask, Verd 'LINHA DO GRID VERDE
.SetCellTextStyle 2, Count, "SIMPLEX" 'TIPO DE LETRA DA LINHA 2
.SetCellTextStyle 3, Count, "SIMPLEX" 'TIPO DE LETRA 3
.SetCellAlignment 3, Count, acMiddleRight 'ALINHAMENTO CENTRO DIREITA LINHA 3
' .SetScale 2, Count, 1, 1
' .SetScale 3, Count, 1, 1
'.SetCellContentColor 2, Count, Verd
.SetCellContentColor 3, Count, Verd 'COR VERDE DAS LETRAS DA LINHA 3
Count = Count + 1
Wend
'CENTRALIZAÇÃO DAS LINHAS 0 E 3
.SetCellAlignment 0, 0, acMiddleCenter 'ALINHAMENTO CENTRO CENTRO LINHA 0
.SetCellAlignment 3, 0, acMiddleCenter 'ALINHAMENTO CENTRO CENTRO CÉLULA 0 DA LINHA 3
'PINTURA AZUL NOS GRIDS
Count3 = 0 'SITUAÇÃO 3
While Count3 < 4
.SetCellGridColor Count3, 0, AcCellEdgeMask.acLeftMask, Cyan 'COLUNAS CYAN NA BORDA DIREITA
.SetCellGridColor Count3, -1, AcCellEdgeMask.acRightMask, Cyan 'COLUNAS CYAN NA BORDA ESQUERDA
Count3 = Count3 + 1
Wend
'PINTURA VERDE NOS GRIDS
Count2 = 1 'SITUAÇÃO 2
While Count2 < 9
.SetCellGridColor 2, Count2, AcCellEdgeMask.acLeftMask, Verd 'COLUNAS VERDES NA LINHA 2
.SetCellGridColor 3, Count2, AcCellEdgeMask.acLeftMask, Verd 'COLUNAS VERDES NA LINHA 3
.SetMargin 2, Count2, acCellMarginRight, MC '* SCX
.SetMargin 3, Count2, acCellMarginRight, MC '* SCX
Count2 = Count2 + 1
Wend
'DEFINIÇÃO E CRIAÇÃO DAS PRIMEIRAS 4 LINHAS
.SetCellGridColor 0, 2, AcCellEdgeMask.acRightMask, Cyan 'COLUNA CYAN
.SetCellGridColor NumCols, 0, AcCellEdgeMask.acTopMask, Cyan 'LINHA SUPERIOR CYAN DO GRID
.SetCellTextStyle 0, 0, "SIMPLEX" 'ESTILO DE LETRA DA CÉLULA 0
.SetText 0, 0, "TABELA DE DADOS - CAIXA DE ESGOTO" 'TITULO DA TABELA
.SetText 2, 0, "CAIXA" 'CABESSALHO COLUNA 1/9
.SetText 2, 1, "NIVEL TAMPA (m)" 'CABESSALHO COLUNA 2/9
.SetText 2, 2, "NIVEL LAJE (m)" 'CABESSALHO COLUNA 3/9
.SetText 2, 3, "NIVEL FUNDO (m)" 'CABESSALHO COLUNA 4/9
.SetText 2, 4, "DIMENS A (m)" 'CABESSALHO COLUNA 5/9
.SetText 2, 5, "DIMENS B (m)" 'CABESSALHO COLUNA 6/9
.SetText 2, 6, "COORD X (m)" 'CABESSALHO COLUNA 7/9
.SetText 2, 7, "COORD Y (m)" 'CABESSALHO COLUNA 8/9
.SetText 2, 8, "AZIMUTE (graus)" 'CABESSALHO COLUNA 9/9
'PRENCHIMENTO DAS CÉLULAS
If NAME = "-pvqua" Then 'SITUAÇÃO DO POSTO DE VISTA QUADRADO
If NumNCE - 1 < 10 Then 'SITUAÇÃO DE DE COLOCAR OU NÃO O ZERO NA CÉLULA 1/9
.SetText 3, 0, TagBl & "0" & NumNCE - 1 'PRENCHENDO A CÉLULA 1/9 DA LINHA 3 COLOCANDO O ZERO
Else
.SetText 3, 0, TagBl & NumNCE - 1 'PRENCHENDO A CÉLULA 1/9 DA LINHA 3 COLOCANDO NÃO COLOCANDO O ZERO
End If
.SetText 3, 1, NumNDT 'PRENCHENDO A CÉLULA 2/9 DA LINHA 3
.SetText 3, 2, NumNDC 'PRENCHENDO A CÉLULA 3/9 DA LINHA 3
.SetText 3, 3, PV 'PRENCHENDO A CÉLULA 4/9 DA LINHA 3
.SetText 3, 4, DimeA 'PRENCHENDO A CÉLULA 5/9 DA LINHA 3
.SetText 3, 5, DimeB 'PRENCHENDO A CÉLULA 6/9 DA LINHA 3
.SetText 3, 6, CodX 'PRENCHENDO A CÉLULA 7/9 DA LINHA 3
.SetText 3, 7, CodY 'PRENCHENDO A CÉLULA 8/9 DA LINHA 3
.SetText 3, 8, ANGEND 'PRENCHENDO A CÉLULA 9/9 DA LINHA 3
ElseIf NAME = "-pvcir" Then 'SITUAÇÃO DO POSTO DE VISTA CIRCULAR
If NumNCE - 1 < 10 Then 'SITUAÇÃO DE DE COLOCAR OU NÃO O ZERO NA CÉLULA 1/9
.SetText 3, 0, TagBl & "0" & NumNCE - 1 'PRENCHENDO A CÉLULA 1/9 DA LINHA 3 COLOCANDO O ZERO
Else
.SetText 3, 0, TagBl & NumNCE - 1 'PRENCHENDO A CÉLULA 1/9 DA LINHA 3 COLOCANDO NÃO COLOCANDO O ZERO
End If
.SetText 3, 1, NumNDT 'PRENCHENDO A CÉLULA 2/9 DA LINHA 3
.SetText 3, 2, NumNDC 'PRENCHENDO A CÉLULA 3/9 DA LINHA 3
.SetText 3, 3, NumNTE 'PRENCHENDO A CÉLULA 4/9 DA LINHA 3
.SetText 3, 4, DimeA * 2 'PRENCHENDO A CÉLULA 5/9 DA LINHA 3
.SetText 3, 5, DimeB * 2 'PRENCHENDO A CÉLULA 6/9 DA LINHA 3
.SetText 3, 6, CodX 'PRENCHENDO A CÉLULA 7/9 DA LINHA 3
.SetText 3, 7, CodY 'PRENCHENDO A CÉLULA 8/9 DA LINHA 3
.SetText 3, 8, ANGEND 'PRENCHENDO A CÉLULA 9/9 DA LINHA 3
Else 'SITUAÇÃO DA CAIXA DE ESGOTO
If NumNCE - 1 < 10 Then 'SITUAÇÃO DE DE COLOCAR OU NÃO O ZERO NA CÉLULA 1/9
.SetText 3, 0, TagBl & "0" & NumNCE - 1 'PRENCHENDO A CÉLULA 1/9 DA LINHA 3 COLOCANDO O ZERO
Else
.SetText 3, 0, TagBl & NumNCE - 1 'PRENCHENDO A CÉLULA 1/9 DA LINHA 3 COLOCANDO NÃO COLOCANDO O ZERO
End If
.SetText 3, 1, NumNDT 'PRENCHENDO A CÉLULA 2/9 DA LINHA 3
.SetText 3, 2, NumNDC 'PRENCHENDO A CÉLULA 3/9 DA LINHA 3
.SetText 3, 3, "N/A" 'PRENCHENDO A CÉLULA 4/9 DA LINHA 3
.SetText 3, 4, DimeA 'PRENCHENDO A CÉLULA 5/9 DA LINHA 3
.SetText 3, 5, DimeB 'PRENCHENDO A CÉLULA 6/9 DA LINHA 3
.SetText 3, 6, CodX 'PRENCHENDO A CÉLULA 7/9 DA LINHA 3
.SetText 3, 7, CodY 'PRENCHENDO A CÉLULA 8/9 DA LINHA 3
.SetText 3, 8, ANGEND 'PRENCHENDO A CÉLULA 9/9 DA LINHA 3
End If
.Rotate PtInsShf, AngTC 'ROTAÇÃO E ANGULO DE INSEÇÃO DA TABELA
.Layer = "AHD" 'LAYER DA TABELA
End With
End If
Else
FimSel = 0 'LIBERA DO WHILE
End If
Loop
'DESENVOLVIDO POR VC 16/04/24
End Subwithout using the ati deformation factor as it should be (result carried out in a file):
without using the ati deformation factor (performed in another file at another scale):
attached dynamic block file
