Atribute to Data Base Access

[jplujan]

Hello:
I am beginning to know the VBA and I would like to make this

I would to send the attributes of a drawing to a data base, I send the code which creates the data base to me and it begins to me to send information until a certain attribute and profit not to know the cause, thanks in advance.

Code:


'---------------------------------------------------------------------------------------
' Module : UserForm1
' DateTime : 29/06/06 16:18
' Author : J.P.Luján
' Purpose :Conexion de AutoCAD con Access con DAO
'---------------------------------------------------------------------------------------
Option Explicit

Public wksObj As Object
Public dbsObj As Object
Public tblObj As Object
Public fldObj As Object
Public rstObj As Object


'---------------------------------------------------------------------------------------
' Procedure : CmdBorrarBD_Click
' DateTime : 29/06/06 14:24
' Author : J.P.Luján
' Purpose :Borrado de la BD
'---------------------------------------------------------------------------------------
'
Private Sub CmdBorrarBD_Click()
Kill (TxtNombreBD.Value)

End Sub

'---------------------------------------------------------------------------------------
' Procedure : CmdCreaBD_Click
' DateTime : 28/06/2006 22:12
' Author : J.P.Luján
' Purpose :Crea BD con nombre del dibujo
'---------------------------------------------------------------------------------------
'
Private Sub CmdCreaBD_Click()
Set wksObj = DBEngine.Workspaces(0)
'If Dir$(TxtNombreBD.Value) <> "" Then
Set dbsObj = wksObj.CreateDatabase(TxtNombreBD.Text, dbLangGeneral) 'Creo la BD con el nombre del cuadro de texto
Set tblObj = dbsObj.CreateTableDef("TblBOOM")

With tblObj
.Fields.Append .CreateField("Handle", dbText) 'Handle de la entidad
.Fields.Append .CreateField("Posicion", dbText) '1Genst
.Fields.Append .CreateField("Cantidad", dbText) '2Genst
.Fields.Append .CreateField("Descripcion_castellano", dbText) '5Genst
.Fields.Append .CreateField("Descripcion_aleman_ingles", dbText) '6Genst
.Fields.Append .CreateField("Norma_proveedor", dbText) '7Genst
.Fields.Append .CreateField("Material_1", dbText) '9Genst
.Fields.Append .CreateField("Material_2", dbText) '10Genst
.Fields.Append .CreateField("N_SAP", dbText) '11Genst
.Fields.Append .CreateField("Esp", dbText) '15Genst
.Fields.Append .CreateField("N_Plano", dbText) '16Genst
.Fields.Append .CreateField("Eng_D", dbText) 'Genst17
End With
dbsObj.TableDefs.Append tblObj
dbsObj.TableDefs.Refresh
Set rstObj = dbsObj.OpenRecordset("tblBoom", dbOpenTable)


'Else

'Kill (TxtNombreBD.Value)
'End If
End Sub
'---------------------------------------------------------------------------------------
' Procedure : CmdVolcado_Click
' DateTime : 28/06/2006 22:11
' Author : J.P.Luján
' Purpose :Vuelca datos de atributos a la BD
'---------------------------------------------------------------------------------------
'
Private Sub CmdVolcado_Click()
Dim mspace As Object
Dim Header As Boolean
Dim elem As AcadEntity
Dim Array1 As Variant
'Dim Array2 As Variant
Dim Count As Integer
Dim tsr As String
Dim Tsr1 As String
Dim Shand As String
Header = False
'Abro la BD
Set dbsObj = DBEngine.Workspaces(0).OpenDatabase(TxtNombreBD.Text)
'Abro la tabla Boom
Set rstObj = dbsObj.OpenRecordset("tblBoom", dbOpenTable)
For Each elem In ThisDrawing.ModelSpace
With elem
rstObj.AddNew
' Si encuentra referencia de bloque, chequea sus atributos
If StrComp(.EntityName, "AcDbBlockReference", 1) = 0 Then
If .HasAttributes Then
' Lee atributos
Array1 = .GetAttributes
Shand = .Handle
' Copia textstring del atributo en la tabla
For Count = LBound(Array1) To UBound(Array1)
If Header = False Then
If StrComp(Array1(Count).EntityName, "AcDbAttribute", 1) = 0 Then
tsr = Array1(Count).TagString
Tsr1 = Array1(Count).TextString
Select Case tsr
'La opción Case es sensible a contenido
Case "Handle"
rstObj!Handle = Shand
Case "1GENST"
rstObj!Posicion = Array1(Count).TextString
Case "2GENST"
rstObj!Cantidad = Array1(Count).TextString
Case "5GENST"
rstObj!Descripcion_castellano = Array1(Count).TextString
Case "6GENST"
rstObj!Descripcion_aleman_ingles = Array1(Count).TextString
Case "7GENST"
rstObj!Norma_proveedor = Array1(Count).TextString
Case "9GENST"
rstObj!Material_1 = Array1(Count).TextString
Case "10GENST"
rstObj!Material_2 = Array1(Count).TextString
Case "11GENST"
rstObj!N_SAP = Array1(Count).TextString
Case "15GENST"
rstObj!Esp = Array1(Count).TextString
Case "16GENST"
rstObj!N_Plano = Array1(Count).TextString
Case "17GENST"
rstObj!Eng_D = Array1(Count).TextString
rstObj.Update
End Select
End If
End If
Next Count
For Count = LBound(Array1) To UBound(Array1)
Next Count
Header = True
End If
End If
End With

Next elem
Set rstObj = Nothing

End Sub

'---------------------------------------------------------------------------------------
' Procedure : UserForm_Activate
' DateTime : 28/06/2006 18:52
' Author : J.P.Luján
' Purpose : Conseguir nombre de la BD a partir del dibujo
'---------------------------------------------------------------------------------------
'
Private Sub UserForm_Activate()

Dim NombreDwg As String
Dim docPath As String

docPath = ThisDrawing.Path
NombreDwg = Left(ThisDrawing.Name, Len(ThisDrawing.Name) - 4) 'Quito al nombre del dibujo la extension
TxtNombreBD.Value = docPath & "\" & NombreDwg & ".mdb"

End Sub

 

[TCARPENTER]

Hi jplujan,

Look here and see if this helps: faq687-5800

HTH
Todd