Path: csiph.com!feeder.erje.net!2.us.feeder.erje.net!news.glorb.com!Xl.tags.giganews.com!border1.nntp.dca1.giganews.com!nntp.giganews.com!local2.nntp.dca.giganews.com!nntp.newsgroupbanter.com!news.newsgroupbanter.com.POSTED!not-for-mail
NNTP-Posting-Date: Sun, 05 Jun 2016 14:49:00 -0500
From: TimLeonard <TimLeonard.119a37a8@excelbanter.com>
Newsgroups: microsoft.public.excel.programming
Subject: Modify Code to loop back through table after its been updated and process it
Date: Sun, 5 Jun 2016 20:21:38 +0100
Message-ID: <TimLeonard.119a37a8@excelbanter.com>
Organization: ExcelBanter.com
User-Agent: 
X-Newsreader: 
X-Originating-IP: 
Lines: 178
X-Usenet-Provider: http://www.giganews.com
X-Trace: sv3-NUYHWvJgOx5n3XFXR9UamwgVmj6u+4hrhdvKCogXvnukS3rDCK8B1BF0KAcKfx46WtvVqxdLs3blOTL!kL80xLPwSQNp1F/4onilc9P9QPSqrB4XEtXFtYCBTcGaP8w5oRYHnlOi9D+kBPJZQ5ZtmOT2RKHV!I9wY8BatBqJR
X-Complaints-To: abuse@newsgroupbanter.com
X-Abuse-and-DMCA-Info: Please be sure to forward a copy of ALL headers
X-Abuse-and-DMCA-Info: Otherwise we will be unable to process your complaint properly
X-Postfilter: 1.3.40
X-Original-Lines: 1
X-Original-Bytes: 5471
Xref: csiph.com microsoft.public.excel.programming:108880


I have been looking for a way to expand the following code to update
some attribute block values (Tagstrings) after modifying the spreadsheet
but with no success.

What I am trying to do is, after populating the Attribute Table, update
the table with new values, then send the updated Attribute Table values
back to the attributes. I am not sure how to pull it back in to VBA and
then loop through it in order to update the attribute blocks

I really appreciate any help that can be provided. I have been
searching and working at this for days.




Code:
--------------------
    
  Sub ExtractAtts_With_Filters() 
  
  Dim Xl As Excel.Application
  Dim XlSheet As Object
  Dim XlWorkbook As Object
  
  Dim RowNum As Integer
  Dim Header As Boolean
  Dim elem As AcadEntity
  Dim Array1 As Variant
  Dim count As Integer
  Dim blk As AcadBlockReference
  
  
  '****************************************************
  'Delete the .xls Attribute Report File
  Dim KillFile As String
  varPath = ThisDrawing.Path
  
  On Error GoTo Exit_XL_App
  KillFile = varPath & "\" & "Attribute.xls"
  
  'Check that file exists
  If Len(Dir$(KillFile)) > 0 Then
  'First remove readonly attribute, if set
  SetAttr KillFile, vbNormal
  'Then delete the file
  Kill KillFile
  End If
  
  
  
  ' Launch Excel and Get Attributes***************************.
  Set Xl = New Excel.Application
  Xl.Visible = True
  
  ' Create a new workbook and find the active sheet.
  Set XlWorkbook = Xl.Workbooks.Add
  Set XlSheet = Xl.ActiveSheet
  XlWorkbook.SaveAs fileName:=varPath & "\" & "Attribute.xls", FileFormat:=1
  
  RowNum = 1
  Header = False
  
  ' Iterate through model space finding
  ' all block references.
  For Each elem In ThisDrawing.ModelSpace
  With elem
  ' When a block reference has been found,
  ' check it for attributes
  If StrComp(.EntityName, "AcDbBlockReference", 1) = 0 Then
  If .HasAttributes Then
  ' Get the attributes
  Array1 = .GetAttributes
  
  
  
  ' Filter through a list of attribute tagstrings in the current block.
  ' Cycle throught the list of attributes.
  For i = LBound(Array1) To UBound(Array1)
  ' Check for the correct attribute tag.
  Dim Attrib As AcadAttributeReference
  Set Attrib = Array1(i)
  ' If the Tagstring containd "Addresses" then
  ' Copy the Tagstrings into Excel
  If Attrib.TagString = "ADDRESS" Then
  
  
  
  ' Copy the Tagstrings for the
  ' Attributes into Excel
  For count = LBound(Array1) To UBound(Array1)
  If Header = False Then
  If StrComp(Array1(count).EntityName, "AcDbAttribute", 1) = 0 Then
  XlSheet.Range("A1") = "HANDLE" 'Code below adds column names
  XlSheet.Cells(RowNum, count + 2).value = Array1(count).TagString
  
  End If
  End If
  
  Next count
  
  RowNum = RowNum + 1
  For count = LBound(Array1) To UBound(Array1)
  If XlSheet.Range("A" & RowNum) = False Then
  XlSheet.Range("A" & RowNum) = "'" & "'" & elem.Handle 'Fill the columns with block data from modelspace
  End If
  XlSheet.Cells(RowNum, count + 2).value = Array1(count).TextString
  
  Next count
  
  Header = True
  End If
  Next i 'Next Filter Check
  
  End If
  End If
  End With
  Next elem
  
  Xl.Sheets("Sheet1").Cells.EntireColumn.AutoFit
  
  
  
  '************************************************************
  '   'HERE is where the code to pull updated table from access goes&#8230;
  '    Attribs(0).TextString = "THIS IS THE NEW NEW VALUE!"
  '
  '    ' Get the attributes again
  '    Dim newAttrib As Variant
  '    newAttrib = blkEntity.GetAttributes
  '
  '    ' Again, display the tags and values
  '    strAttributes = ""
  '    For i = LBound(newAttrib) To UBound(newAttrib)
  '        strAttributes = strAttributes + "  Tag: " + _
  '        newAttribs(i).TagString + vbCrLf + _
  '        "   Value: " + newAttribs(i).TextString
  '************************************************************
  
  
  'Xl.DisplayAlerts = False
  XlWorkbook.Save
  XlWorkbook.Close True '*** uncomment to keep open
  Xl.DisplayAlerts = True
  Xl.Quit
  
  Set XlSheet = Nothing
  Set XlWorkbook = Nothing
  Set Xl = Nothing
  GoTo Exit_Sub
  
  
  Exit_XL_App:
  
  MsgBox Err.Number & " - " & Err.Description & " Error occurred in Excel App Process"
  
  Xl.DisplayAlerts = False
  'XlBook.Save
  XlWorkbook.Close True '*** uncomment to keep open
  Xl.DisplayAlerts = True
  Xl.Quit
  
  Set XlSheet = Nothing
  Set XlWorkbook = Nothing
  Set Xl = Nothing
  
  Exit_Sub:
  
  End Sub
  
  
  
--------------------




-- 
TimLeonard