yeah this job is somewhat custom in that both shades do not go to the floor so if you look at my schedule the sond shade is 18 inches shorter the the one above. i'm making the modifications after i get the numbers in the schedule. this is just a small part of the job, the whole thing is 15 floors so you can imagine how tedious it is. anyway give it a shot and let me know if you need any input. Thank you very much for your efforts i'm excited to see what you come up with.
What I have so far
How it works
Create copy of your working Excel file
Change in VBA code the name of this file
Change reference to MS Excel in VBAIDE to
your current version
After you'll run sub, first of all select room label
(I don't know what the kind of sort the object it is,
I added 'If' statement for both text and attribute)
second, select one by another the texts in
order left-right, left-right etc, then after last selected
text hit Enter
Then make the same manipulations with other
rooms
At the end push Enter twice
Sorry for the bad explanations, also, translate all
promts
Duh, what the heck is "sond"?
Option Explicit
Public xlApp As Excel.Application
Public xlBook As Workbook
Public xlSheet As worksheet
Public strFilePath As String
Dim rowNum As Long
Public iRow As Long
Sub getShadows()
Dim oSset As AcadSelectionSet
Dim oEnt As AcadEntity
Dim varPt As Variant
Dim oText As AcadText
Dim oAtt As AcadAttributeReference
Dim iCnt As Integer
Dim tmx, ctx
Dim fcode(0) As Integer
Dim fData(0) As Variant
Dim dxfcode, dxfdata
Dim setName As String
Dim i As Long, icol As Long
Dim sond As Double
sond = CDbl(InputBox(vbCr & vbCr & "Enter shadow sond increment:", _
"Shadow Sizes", "18"))
fcode(0) = 0
fData(0) = "TEXT"
dxfcode = fcode
dxfdata = fData
setName = "$TEXT$"
strFilePath = ThisDrawing.Path & "\Dat.xls" '// <-- change to your suit
Set xlApp = CreateObject("Excel.Application.11")
xlApp.Visible = True
Set xlBook = xlApp.Workbooks.Open(strFilePath, True, False)
Set xlSheet = xlBook.Worksheets(1)
On Error GoTo Exit_Sub
xlSheet.Activate
xlApp.WindowState = xlMinimized
' get last cell row in the column "C"
iRow = xlSheet.Range("C:C").Cells.SpecialCells(xlCellTypeLastCell).Row
' start from next row
iRow = iRow + 1
Do While True
For i = 0 To ThisDrawing.SelectionSets.Count - 1
If ThisDrawing.SelectionSets.Item(i).Name = setName Then
ThisDrawing.SelectionSets.Item(i).Delete
Exit For
End If
Next i
Dim room As String
ThisDrawing.Utility.GetSubEntity oEnt, varPt, tmx, ctx, vbCr & "Select room label text" & vbCr & _
"(Press Enter to Exit loop) :"
If TypeOf oEnt Is AcadText Then
Set oText = oEnt
room = oText.TextString
ElseIf TypeOf oEnt Is AcadAttributeReference Then
Set oAtt = oEnt
room = oAtt.TextString
End If
Set oSset = ThisDrawing.SelectionSets.Add(setName)
oSset.SelectOnScreen dxfcode, dxfdata
'//MsgBox oSset.Count <-- debug only
Dim coll As Collection
Set coll = New Collection
Dim itm(1) As String
coll.Add room
Erase itm '<--optional
For i = 0 To oSset.Count - 1 Step 2
Set oEnt = oSset.Item(i)
Set oText = oEnt
itm(0) = oText.TextString
Set oEnt = oSset.Item(i + 1)
Set oText = oEnt
itm(1) = oText.TextString
coll.Add itm
itm(0) = itm(0)
itm(1) = itm(1) - sond
coll.Add itm
Next
oSset.Delete
Set oSset = Nothing
rowNum = iRow
xlSheet.Cells(iRow, 3) = coll.Item(1)
With xlSheet
For i = 2 To coll.Count
.Cells(iRow, 7) = coll.Item(i)(0)
.Cells(iRow, 8) = coll.Item(i)(1)
iRow = iRow + 1
Next i
.Columns(1).HorizontalAlignment = xlCenter
.Range(Cells(rowNum, 3), Cells(iRow - 1, 3)).VerticalAlignment = xlCenter
.Range(Cells(rowNum, 3), Cells(iRow - 1, 3)).Merge
End With
For i = coll.Count To 1 Step -1
coll.Remove 1
Next
Loop
Exit_Sub:
Set xlSheet = Nothing
Set xlBook = Nothing
Set xlApp = Nothing
Err_control:
If Err.Number <> 0 Then
If Err.Description Like "*failed" Then
MsgBox "Interrupted by user"
Else
MsgBox Err.Description
End If
Resume Exit_Sub
End If
End Sub
~'J'~
