still having problems from autocad to excel.. i REAALLLY need some help

[btraemoore]

at this point I'm just trying to work in excel from autocad..

 

I'm getting "error '1004' application-defined or object-defined error"

 

here is all the code i have....

 

"EDIT: maybe im not giving enough information. What i'm trying to do is get a collection of text that matches a specific criteria, open an excel spreadsheet, look for each in the first colomn of the spreadsheet, if the value from the dwg match the value in the cell, copy the entire row to a different spread sheet. once they are all found or as many as possible save it. i will notate red in the code.

 

Global Dwg_Name As String, Cur_TxtSTR As String, EOC As Integer
Global text_coll As New Collection
'declaration of public variables
---------------------------------------------------------

Sub SS_delete(X As Byte)
   If ThisDrawing.SelectionSets.Count > 0 Then
   Dim i As Integer
       On Error Resume Next
       For i = 0 To ThisDrawing.SelectionSets.Count - 1
           ThisDrawing.SelectionSets.Item(i).Delete
       Next i
       On Error GoTo 0
   End If
End Sub
-----------------------------------------------------------------

Sub GetText()
   Dim gpCode(1) As Integer
   Dim dataValue(1) As Variant
   Dim SS_text As AcadSelectionSet
   Dim i As Integer
       Dwg_Name = ActiveDocument.Name
   Dim Ncnt As Integer
       Ncnt = Len(Dwg_Name)
       
   Select Case Ncnt
       Case 17
           Dwg_Name = Mid(Dwg_Name, 1, 13)
       Case 18
           Dwg_Name = Mid(Dwg_Name, 1, 14)
       Case 19
           Dwg_Name = Mid(Dwg_Name, 1, 15)
       Case 20
           Dwg_Name = Mid(Dwg_Name, 1, 16)
   End Select
   
   SS_delete 1
   
   Set SS_text = ThisDrawing.SelectionSets.Add("SS_text")'------[color="red"]get a ss of text[/color]
       gpCode(0) = 0: dataValue(0) = "*text"
       gpCode(1) = 8: dataValue(1) = "text"
       
   SS_text.Select acSelectionSetAll, , , gpCode, dataValue
   
   Dim cur_txtObj As AcadText
   Dim Ccnt As Integer, C As Integer
   Dim Ent As AcadEntity
      
   For Each Ent In SS_text'------[color="red"]modify the text entities that i need[/color]
       If UCase(Ent.ObjectName) = UCase("ACDBTEXT") _
       Or UCase(Ent.ObjectName) = UCase("ACDBMTEXT") Then
           Set cur_txtObj = Ent
               Cur_TxtSTR = cur_txtObj.TextString
               Ccnt = Len(Cur_TxtSTR)
           If Ccnt <= 6 And Mid(Cur_TxtSTR, 4, 1) = "-" Then
               Cur_TxtSTR = "CCU3-" & Cur_TxtSTR
                text_coll.Add Cur_TxtSTR
           End If
           
       End If
   
   Next Ent
   EOC = text_coll.Count
   C = 1
   For i = 1 To EOC'----- [color="red"]remove doubles from collection if there are any[/color]
       If C > EOC Then Exit For
       Cur_TxtSTR = text_coll(i)
           For n = 2 To EOC
           If Cur_TxtSTR = text_coll(n) And n <> C Then
               text_coll.Remove (n)
               EOC = text_coll.Count
               Exit For
           End If
       Next n
       C = C + 1
   Next i
   RetrieveEXC
   ExcelWork
End Sub
-------------------------------------------------------------
module 2

' Declare Working Directory
   Global Const WrkDir = "C:\Documents and Settings\moorerb\Desktop\asset worksheets\"
' Declare Excel Workbook name
   Global Const Master_WorkBook = WrkDir & "bptags.xls"
   Global Const Secondary_WorkBook = WrkDir & "mytemp.xls"
' Declare Excel Worksheet name
   Global Const Master_WorkSheet = "ccu3"
   Global Const Secondary_WorkSheet = "template"
   Global Const Tertiary_worksheet = "sheet1"
   
   
Global test As Object
Global workbooks As Object
Global ExcelVer As Integer
Global ExcelServer As Object
Global MasWorksheet As Object
Global secWorksheet As Object
Global ObjWorkbook As Object
Global FileSaveName As String
' end of global variables
--------------------------------------------------------------------

Sub RetrieveEXC()'------[color="red"]open excel[/color]
   Set ExcelServer = CreateObject("Excel.Application.11")
       Set workbooks = ExcelServer.workbooks
       workbooks.Add ("C:\Documents and Settings\moorerb\Desktop\asset worksheets\mytemp.xls")
       workbooks.Open (Master_WorkBook)
   Set secWorksheet = ExcelServer.ActiveWorkbook.worksheets(Secondary_WorkSheet)
   Set MasWorksheet = ExcelServer.ActiveWorkbook.worksheets(Master_WorkSheet)
   
       'ExcelServer.WindowState = -4140
       ExcelServer.Visible = True
       FileSaveName = WrkDir & Dwg_Name & ".xls"
End Sub
-----------------------------------------------------------------------

Sub ExcelWork()
   Dim info As Boolean
   Dim RowLocation As Long
   Dim CSearch As Object
   'Dim C_range As Range
        'C_range = (A1)
   info = False
   Dim Ent As AcadEntity
   Dim i As Integer

   MasWorksheet.Activate'---[color="red"]activate the master worksheet[/color]
   
   For i = 1 To EOC
   
   Cur_TxtSTR = text_coll(i)
  [color="#00ffff"] MasWorksheet.Range(A, 1).Activate[/color]
[color="blue"]from the light blue down to light blue is where my biggest issue is.[/color]
   MasWorksheet.Range(Selection, Selection.End(xlDown)).Select
       If Cur_TxtSTR = xlValue Then
           MasWorksheet.RowLocation = ActiveCell.row
           MasWorksheet.Rows(RowLocation).Select
           Selection.Copy
           Selection.ClearContents
           secWorksheet.Activate
           ActiveSheet.Paste
           secWorksheet.Range.Next.row
       Else
           MasWorksheet.Range.Next.row
       End If
   
   Next i

[color="#00ffff"]End Sub[/color]

       
  





Sub set_to_nil()
   Set ExcelServer = Nothing
   Set ObjWorksheet = Nothing
   'set SecWorksheet = nothing
   Set ObjWorkbook = Nothing
   
End Sub

Public Sub save_file()
ActiveWorkbook.SaveAs FileName:= _
       FileSaveName, fileformat:= _
       xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
       , CreateBackup:=False
End Sub

Edited May 29, 2012 by btraemoore

[fixo]

Try to change this code block

 
   Dim oText As AcadText
   Dim oMText As AcadMText
   Dim Ccnt As Integer, C As Integer
   Dim Ent As AcadEntity

   For Each Ent In SS_text
             If TypeOf Ent Is AcadText Then
             Set oText = Ent
                   Cur_TxtSTR = oText.TextString
               Ccnt = Len(Cur_TxtSTR)
           If Ccnt <= 6 And Mid(Cur_TxtSTR, 4, 1) = "-" Then
               Cur_TxtSTR = "CCU3-" & Cur_TxtSTR
                text_coll.Add Cur_TxtSTR
           End If
           End If
       If TypeOf Ent Is AcadMText Then
             Set oMText = Ent

               Cur_TxtSTR = oMText.TextString
               Ccnt = Len(Cur_TxtSTR)
           If Ccnt <= 6 And Mid(Cur_TxtSTR, 4, 1) = "-" Then
               Cur_TxtSTR = "CCU3-" & Cur_TxtSTR
                text_coll.Add Cur_TxtSTR
           End If

       End If

   Next Ent

Again, in this line:

MasWorksheet.Range(A, 1).Activate

variable A is not defined

 

 

~'J'~

Edited May 29, 2012 by fixo

[btraemoore]

thank you very much!!! such a small mistake... i found it yesterday about an hour after i put the code back up, here is what i changed it to.

 

Sub ExcelWork()
   Dim info As Boolean
   Dim RowLocation As Long
   Dim CSearch As Object
   'Dim C_range As Range
        'C_range = (A1)
   info = False
   Dim Ent As AcadEntity
   Dim i As Integer, n As Long
   Dim CurrentItem As String
   Dim pause As Boolean
   Dim match As Object
   MasWorksheet.Activate
   
   MasWorksheet.cells(1, 1).Activate
   'MasWorksheet.Activate.EntireColumn.autofit
   
   For i = 1 To EOC
   Cur_TxtSTR = text_coll(i)
       For n = 1 To 876
       CurrentItem = MasWorksheet.cells(n, 1).Value
           If Cur_TxtSTR = CurrentItem Then
               pause = True
               MasWorksheet.Rows(n).Select
               Set match = MasWorksheet.Rows(n)
               MasWorksheet.Rows(n).ClearContents
               secWorksheet.Activate
               [color="red"]secWorksheet.insert (match)
               'secWorksheet.Range.Next.row[/color][color="blue"] still having issues with this, but researching right now.[/color]
           End If
   
       Next n
       
   Next i

End Sub

 

Thanks again for your insight

[btraemoore]

OK!!! so i completed the routine and wanted to post it for others to learn from...

it is in working order...

this is only my 4th vba routine, enjoy

 

Global Dwg_Name As String, Cur_TxtSTR As String, EOC As Integer
Global text_coll As New Collection
'declaration of public variables

'
' Delete all existing Selection sets
'

Sub SS_delete(X As Byte)
   If ThisDrawing.SelectionSets.Count > 0 Then
   Dim i As Integer
       On Error Resume Next
       For i = 0 To ThisDrawing.SelectionSets.Count - 1
           ThisDrawing.SelectionSets.Item(i).Delete
       Next i
       On Error GoTo 0
   End If
End Sub

'
[color="#2e8b57"]' Work done in autoCAD[/color]
'

Sub gettext()
   Dim gpCode(1) As Integer
   Dim dataValue(1) As Variant
   Dim SS_text As AcadSelectionSet
   Dim i As Integer
       Dwg_Name = ActiveDocument.Name ' get the drawing name
   Dim Ncnt As Integer
       Ncnt = Len(Dwg_Name)
       
   
   Select Case Ncnt [color="#2e8b57"]' remove .dwg from the name[/color]
       Case 17
           Dwg_Name = Mid(Dwg_Name, 1, 13)
       Case 18
           Dwg_Name = Mid(Dwg_Name, 1, 14)
       Case 19
           Dwg_Name = Mid(Dwg_Name, 1, 15)
       Case 20
           Dwg_Name = Mid(Dwg_Name, 1, 16)
   End Select
   
   SS_delete 1
   
   Set SS_text = ThisDrawing.SelectionSets.Add("SS_text")[color="#2e8b57"] ' define our selection set[/color]
       gpCode(0) = 0: dataValue(0) = "*text"
       gpCode(1) = 8: dataValue(1) = "text"
       
   SS_text.Select acSelectionSetAll, , , gpCode, dataValue
   
   Dim cur_txtObj As AcadText
   Dim Ccnt As Integer, c As Integer
   Dim Ent As AcadEntity
      
   ' filter through all text
   For Each Ent In SS_text
       If UCase(Ent.ObjectName) = UCase("ACDBTEXT") _
       Or UCase(Ent.ObjectName) = UCase("ACDBMTEXT") Then
           Set cur_txtObj = Ent
               Cur_TxtSTR = cur_txtObj.TextString            [color="#2e8b57"]'set variable to the contents of the text[/color]
               Ccnt = Len(Cur_TxtSTR)                        [color="#2e8b57"]'get the length of the text string[/color]
           
           If Ccnt <= 8 And Mid(Cur_TxtSTR, 4, 1) = "-" Then [color="#2e8b57"]'looking for text with the 4th chr "-"[/color]
               Cur_TxtSTR = "CCU3-" & Cur_TxtSTR             [color="#2e8b57"]'add "ccu3-" to the front of all applicable text[/color]
               text_coll.Add Cur_TxtSTR                      [color="#2e8b57"]'add text to a collection[/color]
           End If
           
       End If
   
   Next Ent
   
   [color="#2e8b57"]'compare all elements in collection to one another
   'to make sure we dont have any doubles[/color]
   EOC = text_coll.Count
   c = 1 [color="#2e8b57"]' set a count to make sure we don't delete the item we're reading from[/color]
   For i = 1 To EOC [color="#2e8b57"]' i = the item number in collection are are using to compare, EOC = end of collection[/color]
       If c > EOC Then Exit For [color="#2e8b57"]' error handling[/color]
       Cur_TxtSTR = text_coll(i)
       For n = 2 To EOC [color="#2e8b57"]' n = item number in collection we are comparing to[/color]
           If Cur_TxtSTR = text_coll(n) And n <> c Then [color="#2e8b57"]' if they match and is not the same item[/color]
               text_coll.Remove (n) [color="#2e8b57"]' remove it from the collection[/color]
               EOC = text_coll.Count [color="#2e8b57"]' get a new count of items in collection[/color]
               Exit For
           End If
       Next n
       c = c + 1 [color="#2e8b57"]' add 1 to our "c" count since we are moving up 1 in our "i" count[/color]
   Next i
   
   'move to the work done in excel
   RetrieveEXC
   excelwork
End Sub


Sub MakeAssetSheet()
  gettext
End Sub

' Declare Working Directory
   Global Const WrkDir = "C:\Documents and Settings\moorerb\my documents\asset worksheets\"
' Declare Excel Workbook name
   Global Const Master_WorkBook = WrkDir & "bptags.xls"
' Declare Excel Worksheet name
   Global Const Master_WorkSheet = "ccu3"
   Global Const Secondary_WorkSheet = "template"

Global workbooks As Object
Global ExcelVer As Integer
Global ExcelServer As Object
Global MasWorksheet As Object
Global secWorksheet As Object
Global ObjWorkbook As Object
Global FileSaveName As String
' end of global variables

'
' open excel
'

Sub RetrieveEXC()
   Set ExcelServer = CreateObject("Excel.Application.11")
   Set workbooks = ExcelServer.workbooks
       workbooks.Open (Master_WorkBook)
   Set secWorksheet = ExcelServer.activeworkbook.worksheets(Secondary_WorkSheet)
   Set MasWorksheet = ExcelServer.activeworkbook.worksheets(Master_WorkSheet)
   
       'set the window to invisable
       ExcelServer.WindowState = -4140
       ExcelServer.Visible = False
End Sub

'
' work done in excel
'

Sub excelwork()
   Dim i As Integer, n As Long, c As Long
       c = 8
   Dim CurrentItem As String
   Dim pause As Boolean
   Dim match As Variant
   Dim NewSheetName As String
       NewSheetName = Dwg_Name & "assets"
       
  [color="#2e8b57"] 'set a count for items in collection[/color]
   For i = 1 To EOC
   Cur_TxtSTR = text_coll(i)
   MasWorksheet.Activate
   MasWorksheet.cells(1, 3).Activate
   
       'set a count for items in excel spreadsheet
       For n = 1 To 876
       CurrentItem = MasWorksheet.cells(n, 3).Value
           
           'compare collection item to each excel item, until we find our match
           If Cur_TxtSTR = CurrentItem Then
               MasWorksheet.Rows(n).Select               [color="#2e8b57"] ' select the row[/color]
               MasWorksheet.Rows(n).Copy                 [color="#2e8b57"] ' copy the row[/color]
               secWorksheet.Activate
               secWorksheet.cells(c, 1).Activate
               secWorksheet.paste                               [color="#2e8b57"]' paste the row in the new sheet[/color]
               secWorksheet.cells(c, 10).Value = Dwg_Name [color="#2e8b57"]' insert the drawing name in new sheet[/color]
               c = c + 1
           End If
   
       Next n
       
   Next i
   
   secWorksheet.Copy ' copy the new sheet
   ExcelServer.activeworkbook.sheets("template").Name = NewSheetName ' set the new sheet name
   FileSaveName = ExcelServer.Application.GetSaveAsFilename _
   (InitialFileName:=Dwg_Name & ".xls", Title:="Save As")            ' choose where we're going to save it
   
   If FileSaveName = "False" Then                         ' error handleing
       MsgBox "File not Saved, Actions Cancelled."
       Exit Sub
   Else
       ExcelServer.activeworkbook.SaveAs FileSaveName ' save it
       ExcelServer.activeworkbook.Close               ' close it
   End If
   
   ExcelServer.Application.DisplayAlerts = False ' hide unwanted alerts
   ExcelServer.workbooks("bptags.xls").Close     ' close the work book
   ExcelServer.Quit                              ' quit excel
   set_to_nil                                    ' function to reset object variables to nothing
   
End Sub


Sub set_to_nil()
   Set workbooks = Nothing
   Set ExcelServer = Nothing
   Set MasWorksheet = Nothing
   Set secWorksheet = Nothing
   Set ObjWorkbook = Nothing
End Sub