TheSwamp
Code Red => VB(A) => Topic started by: jbuzbee on July 12, 2006, 05:45:28 PM
-
I've really tried to get my head around this dictionary stuff in VBA but I'm still having trouble. I've created an xrecord in the namedobjdict with the following LISP:
(defun jb:SaveKeynoteFilename (file / datalist xname newdict)
(setq dataList (append (list '(0 . "XRECORD") '(100 . "AcDbXrecord") (cons 300 file)))
xname (entmakex dataList))
(dictremove (namedobjdict) "JB_KEYNOTE_FILE")
(setq newdict
(dictadd (namedobjdict) "JB_KEYNOTE_FILE" xname)
xname nil)
newdict)
Can anyone give me a start on how to retrieve this data via VBA? Thanks a bunch!
jb
-
REALLY busy today, enough so that I need to quit checking here but oh well. Don't have time to give you a good answer so I'll give you two bad ones.
From help
Sub Example_GetXData()
' This example creates a line and attaches extended data to that line.
' Create the line
Dim lineObj As AcadLine
Dim startPt(0 To 2) As Double, endPt(0 To 2) As Double
startPt(0) = 1#: startPt(1) = 1#: startPt(2) = 0#
endPt(0) = 5#: endPt(1) = 5#: endPt(2) = 0#
Set lineObj = ThisDrawing.ModelSpace.AddLine(startPt, endPt)
ZoomAll
' Initialize all the xdata values. Note that first data in the list should be
' application name and first datatype code should be 1001
Dim DataType(0 To 9) As Integer
Dim Data(0 To 9) As Variant
Dim reals3(0 To 2) As Double
Dim worldPos(0 To 2) As Double
DataType(0) = 1001: Data(0) = "Test_Application"
DataType(1) = 1000: Data(1) = "This is a test for xdata"
DataType(2) = 1003: Data(2) = "0" ' layer
DataType(3) = 1040: Data(3) = 1.23479137438413E+40 ' real
DataType(4) = 1041: Data(4) = 1237324938 ' distance
DataType(5) = 1070: Data(5) = 32767 ' 16 bit Integer
DataType(6) = 1071: Data(6) = 32767 ' 32 bit Integer
DataType(7) = 1042: Data(7) = 10 ' scaleFactor
reals3(0) = -2.95: reals3(1) = 100: reals3(2) = -20
DataType(8) = 1010: Data(8) = reals3 ' real
worldPos(0) = 4: worldPos(1) = 400.99999999: worldPos(2) = 2.798989
DataType(9) = 1011: Data(9) = worldPos ' world space position
' Attach the xdata to the line
lineObj.SetXData DataType, Data
' Return the xdata for the line
Dim xdataOut As Variant
Dim xtypeOut As Variant
lineObj.GetXData "", xtypeOut, xdataOut
End Sub
You would do it the same way the following is barely thought through and entirely untested, just about guaranteed to not work, but should get you going down the right roadSub test()
Dim objDic As AcadDictionary
Dim objDix As AcadDictionaries
Dim varXDO As Variant
Dim varXTO As Variant
Set objDix = ThisDrawing.Dictionaries
For Each objDic In objDix
If objDic.Name = "JB_KEYNOTE_FILE" Then
objDic.GetXData "", varXDO, varXTO
Exit For
End If
Next objDic
End Sub
-
jb I'm posting this as it seems to be a little like you need.
The think i found was that an xrecord will error if you treat it like a dictionary so note vardic is an object.
I think I was messing with this sub to try figure how to get at some lisp from vba. Share the pain.
Sub Dimstuff()
'(dictremove (namedobjdict) "AcadDim")
'(setq cur (append '((0 . "XRECORD") (100 . "AcDbXrecord") (90 . 990106)) cur))
'(dictadd (namedobjdict) "AcadDim" (entmakex cur))
'(acet-ql-get)
Dim varDic As AcadObject
Dim oDic As AcadDictionary
Dim oDics As AcadDictionaries
Dim x As AcadXRecord
Dim i As Integer
Dim XRecordDataType As Variant, XRecordData As Variant
Dim ArraySize As Long, iCount As Long
Dim DataType As Integer, Data As String, msg As String
Dim isThere As Boolean
Set oDics = ThisDrawing.Dictionaries
For Each varDic In oDics
If TypeOf varDic Is AcadXRecord Then
Debug.Print "XRecord=" & varDic.Name
If varDic.Name = "AcadDim" Then
Set x = varDic
isThere = True
Exit For
End If
End If
If TypeOf varDic Is AcadDictionary Then
Debug.Print "Dictionary=" & varDic.Name
If varDic.Name = "AcadDim" Then
Set oDic = varDic
For Each x In oDic
Debug.Print x.Name
Next
'Set X = oDic.GetObject("AcadDim")
'IsThere = True
Exit For
End If
End If
Next
If Not isThere Then
Debug.Print isThere
Dim xType(16) As Integer, XData(16)
xType(0) = 90: XData(0) = 990106
xType(1) = 3: XData(1) = ""
xType(2) = 40: XData(2) = 0
xType(3) = 60: XData(3) = 0
xType(4) = 61: XData(4) = 0
xType(5) = 62: XData(5) = 2
xType(6) = 63: XData(6) = 2
xType(7) = 64: XData(7) = 0
xType(8) = 65: XData(8) = 0
xType(9) = 66: XData(9) = 0
xType(10) = 67: XData(10) = 3
xType(11) = 68: XData(11) = 0
xType(12) = 69: XData(12) = 0
xType(13) = 70: XData(13) = 0
xType(14) = 71: XData(14) = 1
xType(15) = 72: XData(15) = 0
xType(16) = 170: XData(16) = 0
Set oDic = oDics.Add("AcadDim")
Set x = oDic.AddXRecord("AcadDim")
x.SetXRecordData xType, XData
End If
For Each varDic In oDics
'Debug.Print varDic.ObjectName
If TypeOf varDic Is AcadDictionary Then
Debug.Print varDic.Name
End If
If TypeOf varDic Is AcadXRecord Then
Debug.Print "XRecord=" & varDic.Name
End If
Next
On Error Resume Next
x.GetXRecordData XRecordDataType, XRecordData
For i = 0 To UBound(XRecordDataType)
' Get information for this element
DataType = XRecordDataType(i)
Data = XRecordData(i)
Debug.Print i, DataType, Data
Next
End Sub
-
Thanks for the help guys!
Argh - I still don't like dictionaries in VBA! It's so simple in LISP!!!
Here's what I ended up with:
Public Sub jbKeyNotesFormRefresh()
Dim KeynoteDict As AcadDictionary, KeynoteXRecord As AcadXRecord
Dim XRecordDataType As Variant, XRecordData As Variant
Dim ArraySize As Long, iCount As Long
Dim DataType As Integer, Data As String, msg As String
Dim file As String, str As String
' Unique identifiers to distinguish this XRecordData from other XRecordData
Const TYPE_STRING = 300
Const TAG_DICTIONARY_NAME = "JB_KEYNOTE"
Const TAG_XRECORD_NAME = "JB_KEYNOTE_FILE"
' Connect to the dictionary in which to store the XRecord
On Error GoTo ERR
Set KeynoteDict = ThisDrawing.Dictionaries(TAG_DICTIONARY_NAME)
Set KeynoteXRecord = KeynoteDict.GetObject(TAG_XRECORD_NAME)
On Error GoTo 0
' Get current XRecordData
KeynoteXRecord.GetXRecordData XRecordDataType, XRecordData
' If there is no array yet then create one
If VarType(XRecordDataType) And vbArray = vbArray Then
ArraySize = UBound(XRecordDataType) + 1 ' Get the size of the data elements returned
ArraySize = ArraySize + 1 ' Increase to hold new data
ReDim Preserve XRecordDataType(0 To ArraySize)
ReDim Preserve XRecordData(0 To ArraySize)
Else
ArraySize = 0
ReDim XRecordDataType(0 To ArraySize) As Integer
ReDim XRecordData(0 To ArraySize) As Variant
End If
' Read back all XRecordData entries
KeynoteXRecord.GetXRecordData XRecordDataType, XRecordData
ArraySize = UBound(XRecordDataType)
' Retrieve and display stored XRecordData
For iCount = 0 To ArraySize
' Get information for this element
DataType = XRecordDataType(iCount)
Data = XRecordData(iCount)
If DataType = TYPE_STRING Then
file = Data
End If
Next
KeyNotes.ListBox2.Clear
On Error GoTo ErrMessage
If Not file = "" Then
Open file For Input As #1
Do While Not EOF(1)
Input #1, str
KeyNotes.ListBox2.AddItem (str)
Loop
Close #1
End If
ErrMessage:
Close #1
Exit Sub
Exit Sub
ERR:
KeyNotes.ListBox2.Clear
End Sub
I included the dictionary stuff in the Form Refresh code because I can't figure out how to pass variables between functions??
jb
-
Here's a really simple thing that will hopefully clear it up
public sub test()
Dim strOne as String
dim StrTwo as string
dim intOne as integer
dim intTwo as integer
strone = "This"
strtwo = "a (hopefully simple to"
intone = 3
inttwo = 1
msgbox stringmaker(strone,strtwo,intone,inttwo)
end sub
Public Function StringMaker(strA as string, strB as string, intA as integer, intB as integer) as string
stringmaker = strA & " is " & strB & " understand) demonstration on passing data to and from a function as easy as " & intb & ", 2, " & inta
end function