CmdrDuh,
I've reworked your code "a bit" and added some comments. Two major issues caught my eye.
1) The recorder uses .Select to imitate exactly what is going on, but in code you do not need to select
you can manipulate any object directly if you've placed it in a variable
2) Avoid .active..... because during the run of your code the user can select another in one click of the mouse button (cell,worksheet or workbook alike)
Option Explicit
Dim objSelSet As AcadSelectionSet
Dim objSelected As Object
Dim objExcel As Excel.Application
Dim objExcelSheet As Excel.Worksheet
Dim objExcelWb As Excel.Workbook
Dim objExcelRange As Excel.Range
'Dim objElem As Object
Dim varArray1 As Variant ' Array to store entity attributes
Dim intCount, intActR As Integer ' Counts the number of elements in the array
Dim blnFoundAttributes As Boolean 'Monitors whether entity has attributes
'the boolean noe indicates if Excel was or was not running prior to this macro
Dim blnRunning As Boolean ' Determines if Excel is running
Dim BlnWorkbookPresent As Boolean 'Flags if the workbook was already open
Dim foundCell As Excel.Range ' Cell containing drawing #
Dim objBlkRef As AcadBlockReference
Dim objAttRef As AcadAttributeReference
Dim i As Integer, TotalBlocks As Integer, iCount As Integer, intType(0 To 1) As Integer
Dim varAtts As Variant, Atts As Variant, varData(0 To 1) As Variant
Dim objSelCol As AcadSelectionSets
Dim intQuantity As Integer
Dim strBlockName As String
Dim strStoresNumber As String
Const BottomRowNum = 65536 'eeuw! that is ugly the next Excel will have way more rows!
'you should adjust this
Const FILENAME_PMS = "C:\PMS\Test.xls"
'just for easy use
Const WORKBOOKNAME_PMS = "Test"
Private Sub PMS_Get_Number()
frmPMS.Show
End Sub
'Reworked that one to avoid the loop
Public Function GetLastRow() As Long
Dim Wks As Excel.Worksheet
Set Wks = objExcel.ActiveSheet 'this is a bit dangerous if Excel is visible because the user can activate another sheet
'usedrange defines the area that's been altered on a sheet
'of course the used range can start several rows below the first row.
GetLastRow = Wks.UsedRange.Row + Wks.UsedRange.Rows.Count
Set Wks = Nothing
End Function
Public Sub PMSLog()
On Error GoTo Err_Control:
PMS_Get_Number
Set objSelCol = ThisDrawing.SelectionSets
For Each objSelSet In objSelCol
If objSelSet.Name = "PMS" Then
objSelSet.Delete
Exit For
End If
Next
Set objSelSet = objSelCol.Add("PMS")
intType(0) = 0: varData(0) = "INSERT"
intType(1) = 2: varData(1) = "*"
objSelSet.Select Mode:=acSelectionSetAll, filtertype:=intType, filterdata:=varData
'---------------------------------------------------------
'this is double up because you use getobject to determine
'if excel is running
'use the error to create an instance if it is not running
'blnRunning = IsAppRunning
'---------------------------------------------------------
'If blnRunning Then
' Set objExcel = GetObject(, "Excel.Application")
' objExcel.UserControl = True
' objExcel.Visible = True
'Else
' Set objExcel = CreateObject("Excel.Application")
' objExcel.UserControl = True
' objExcel.Visible = True
' objExcel.Workbooks.Open strpms
'End If
On Error GoTo NoExcel
blnRunning = True 'will be set to false if it wasn't in the error handler
Set objExcel = GetObject(, "Excel.Application")
objExcel.UserControl = True
objExcel.Visible = True
'search for the desired workbook if Excel was already open (you never know!)
If blnRunning Then
For Each objExcelWb In objExcel.Workbooks
If objExcelWb.Name = WORKBOOKNAME_PMS Then
BlnWorkbookPresent = True
Exit For
End If
Next
End If
If Not BlnWorkbookPresent Then Set objExcelWb = objExcel.Workbooks.Open(FILENAME_PMS)
'now you have controle over the workbook because you have an instance
'(objExcelWb) so you can adres it directly
'No use of active needed anymore
Set objExcelSheet = objExcelWb.Sheets("Sheet1")
'to late bind you need to use -4121 instead of xldown (the number it represents)
objExcelSheet.Range("b2", objExcelSheet.Range("b2").End(xlDown)) = Null
objExcelSheet.Range("a2", objExcelSheet.Range("a2").End(xlDown)) = Null
objExcelSheet.Range("a2", objExcelSheet.Range("a2").End(xlDown)).NumberFormat = 0#
objExcelSheet.Range("b2", objExcelSheet.Range("b2").End(xlDown)).NumberFormat = "@"
'objExcelSheet.Range("a2", objExcelSheet.Range("a2").End(xlDown)) = 0
For Each objBlkRef In objSelSet
If objBlkRef.HasAttributes Then
varArray1 = objBlkRef.GetAttributes
For intCount = LBound(varArray1) To UBound(varArray1)
Select Case varArray1(intCount).TagString
Case "STORESNUMBER"
strStoresNumber = varArray1(intCount).TextString
Set foundCell = objExcelSheet.Range("b2", objExcelSheet.Range("b2").End(xlDown)).Find(strStoresNumber)
If foundCell Is Nothing Then
'add stores number to the list
Dim NextLine As Long
NextLine = GetLastRow() + 1
objExcelSheet.Cells(NextLine, 2).Value = strStoresNumber
Else
Set foundCell = Nothing
End If
End Select
Next intCount
End If
Next
'**********************************************************************
'Already set the workbook
'Set objExcelWb = objExcel.ActiveWorkbook
Set objExcelSheet = objExcelWb.Worksheets(1)
'Select is used by the recorde to mimic exactly what you are doing, but in code you do not need to select stuff to alter it.
'Btw: Ranges are defined ("A1:C5") in my Excel not(A1,C5)
Set objExcelRange = objExcelSheet.Range("B2:B" & NextLine) '.Select
objExcelRange.Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortTextAsNumbers
'************************************************************************
While NextLine > 1
objExcelSheet.Cells(NextLine, 1).Value = 0
NextLine = NextLine - 1
Wend
For Each objBlkRef In objSelSet
If objBlkRef.HasAttributes Then
varArray1 = objBlkRef.GetAttributes
For intCount = LBound(varArray1) To UBound(varArray1)
Select Case varArray1(intCount).TagString
Case "STORESNUMBER"
strStoresNumber = varArray1(intCount).TextString
Set foundCell = objExcelSheet.Range("b2", objExcelSheet.Range("b2").End(xlDown)).Find(strStoresNumber)
'Set foundCell = Columns("A").Find(strDwgNo)
If foundCell Is Nothing Then
MsgBox ("Did not find a stores number #")
Exit Sub
Else
'no need to activate
'foundCell.Activate
'Use the object direcly like:
intActR = foundCell.Row
Dim val As String
Set foundCell = Nothing
End If
End Select
Next intCount
objExcelSheet.Cells(intActR, 1).Value = CStr(objExcelSheet.Cells(intActR, 1).Value) + 1
End If
Next objBlkRef
If Not blnRunning Then
'We started the instance, so we can close it
'Again use the object directly and avoid active, users have an annoying habbit of clicking
'while bored.
objExcelWb.Save
objExcel.Quit
Else
objExcelWb.Save
End If
Exit_Here:
' do it the other way around always set the dependent object to nothing first
'(in order of dependancy: Range,Worksheet,Workbook,Application)
'Set objExcel = Nothing
'Set objExcelSheet = Nothing
Set foundCell = Nothing
Set objExcelRange = Nothing
Set objExcelSheet = Nothing
Set objExcelWb = Nothing
Set objExcel = Nothing
Exit Sub
Err_Control:
objExcel.Quit
Set objExcel = Nothing
Set objExcelSheet = Nothing
MsgBox Err.Description, vbOKOnly, Err.Number
Resume Exit_Here
Exit Sub
NoExcel:
Set objExcel = CVreateObject("Excel.Application")
blnRunning = False 'the boolean noe indicates if Excel was or was not running prior to this macro
'continue on the next line for an instance of Excel is now present :)
Resume Next
End Sub
'This determines how to set the Excel instance.
Private Function IsAppRunning() As Boolean
Dim objExcel As Excel.Application
On Error Resume Next
Set objExcel = GetObject(, "Excel.Application")
IsAppRunning = (Err.Number = 0)
Set objExcel = Nothing
Err.Clear
End Function
I can not test it (no acad at home for one, and living at GMT +1) so it bounds to have some bugs.
To late bind it replace all Excel.xxxxx to Object end replace Excel constants like XlDown with their corresponding number.
This way the code will run Excel version independent. Note: keep it early bound while developing, it will save you time.