Problem zasygnalizowany na www.cad.pl/wwwboard, a dotyczący odczytywania kodów DXF obiektu przez VBA. Pomimo tego że do wszystkich danych każdego obiektu VBA ma niczym nieskrępowany dostęp, okazuje się że pewne dane związane z kreskowaniem (dane DXF obwiedni kreskowania) nie są dostępne przez VBA. Jedynym sposobem mógłby być odczyt kodów DXF przez VBA ale... bezpośrednio VBA tego nie potrafi.
W takiej sytuacji nie pozostaje nic innego jak odczyt danych przez LISP-a, i przekazanie ich do VBA, ale (i tu pojawia się problem) - LISP z VBA mają bardzo ograniczone możliwości komunikacyjne. Stosunkowo często wykorzystywany (w obie strony) zapis / odczyt zmiennych systemowych użytkownika, jest skuteczny, lecz tylko dla stosunkowo niewielkich danych. W sytuacjach gdy danych jest dużo, ich ilość jest zmienna i nie jest znana pozostaje... dostęp do obiektu niegraficznego jakim jest XRECORD.
Ponieważ wszystko ma być wykonywane przez VBA pomysł jest prosty:
- VBA zapisuje w katalogu tymczasowym plik o nazwie
hatch.lsp wypełniając go treścią (krótkimi funkcjami lisp-a) a następnie go wczytuje (SendCommand).
- VBA pobiera uchwyt (handle) obiektu (jeżeli użytkownik wskazał kreskowanie)
- VBA (ponownie przez)
SendCommand wywołuje funkcję lispa z argumentem, którym jest pobrany uchwyt kreskowania.
- Następnie Lisp odczytuje i formatuje, oraz zapisuje w obiekcie niegraficznym XRECORD o nazwie
"LISP-HATCH-DATA" dane obwiedni.
- VBA pobiera dane z obiektu XRECORD, a następnie go usuwa.
Na potrzeby takiego rozwiązania napisałem kilka krótkich funkcji lispowych (odczyt danych na podstawie handle, formatowanie danych, założenie XRECORD, zapis do niego danych). Funkcje są krótkie z uwagi na konieczność ich zapisu w pliku przez VBA. Ponieważ nie czuję się kompetentnym w programowaniu VBA całość kodu wykonał specjalista w tej dziedzinie badziewiak, któremu tutaj dziękuję za pomooc. Kod wygląda tak:
|
Option Explicit
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" _
(ByVal nBufferLength As Long , _
ByVal lpBuffer As String) As Long
Public Function GetTempDir() As String
Dim sBuffer As String
Dim lRetVal As Long
sBuffer = String(255, vbNullChar)
lRetVal = GetTempPath(Len(sBuffer), sBuffer)
If lRetVal Then
GetTempDir = Left$(sBuffer, lRetVal)
End If
End Function
Public Sub test()
On Error GoTo BLAD
loadLisp
Dim obiekt As AcadEntity, pnt As Variant
'Pobrac obiekt
ThisDrawing.Utility.GetEntity obiekt, pnt, vbCrLf & "Wskaż kreskowanie: "
If TypeOf obiekt Is AcadHatch Then
Dim daneKresk As Variant
'Jest kreskowanie - pobrac obwiednie
daneKresk = daneKreskowania(obiekt)
End If
BLAD:
End Sub
Public Function loadLisp()
Dim fSobj As Object
Dim tempDir As String
tempDir = GetTempDir
Dim sciezkaLispa As String
sciezkaLispa = Replace(tempDir, "\", "/") & "hatch.lsp"
Set fSobj = CreateObject("Scripting.FileSystemObject")
If Not fSobj.FileExists(tempDir & "hatch.lsp") Then
'Utworzyc lispa
Dim fN As Long
fN = FreeFile
Open tempDir & "hatch.lsp" For Output As fN
Print #fN, "; hatch.lsp by kojacek 2009"
Print #fN, "; sHatchData -> zapisuje xrecord z danymi DXF"
Print #fN, "; gHatchData -> zbiera wszystkie dane "
Print #fN, "; tHatchData -> 'przycina' dane"
Print #fN, "; aHatchData -> tworzy liste dla xrecord"
Print #fN, "; xHatchData -> tworzy xrecord LISP-HATCH-DATA"
Print #fN, "(defun sHatchData (h / d)"
Print #fN, " (if (setq d (gHatchData h)) (xHatchData (aHatchData (reverse "
Print #fN, "(tHatchData (reverse (tHatchData d 92)) 97))))))"
Print #fN, "(defun gHatchData (h / d)"
Print #fN, " (if (= (cdr (assoc 0 (setq d (entget (handent h))))"
Print #fN, ") " & Chr$(34) & "HATCH" & Chr$(34) & ") d nil))"
Print #fN, "(defun tHatchData(d c)"
Print #fN, " (while (/= c (caar d))(setq d (cdr d))))"
Print #fN, "(defun aHatchData(d)"
Print #fN, " (append '((0 . " & Chr$(34) & "XRECORD" & Chr$(34) & ")"
Print #fN, "(100 . " & Chr$(34) & "AcDbXrecord" & Chr$(34) & ")) d))"
Print #fN, "(defun xHatchData(d / x)"
Print #fN, " (setq x (entmakex d))(dictadd "
Print #fN, " (namedobjdict) " & Chr$(34) & "LISP-HATCH-DATA" & Chr$(34) & " x)"
Print #fN, ")(princ)"
Close fN
End If
ThisDrawing.SendCommand "(load " & Chr(34) & sciezkaLispa & Chr(34) & ")" & vbCr
End Function
Public Function daneKreskowania(kreskowanie As AcadHatch) As Variant
On Error GoTo BLAD
daneKreskowania = Empty
skasujXRECORD
ThisDrawing.SendCommand "(sHatchData " & Chr(34) & kreskowanie.Handle & Chr(34) & ")" & vbCr
Dim xrecord As AcadXRecord
Set xrecord = ThisDrawing.Dictionaries("LISP-HATCH-DATA")
xrecord.GetXRecordData 0, daneKreskowania
xrecord.Delete
BLAD:
End Function
Private Function skasujXRECORD()
On Error GoTo BLAD
Dim xrecord As AcadXRecord
Set xrecord = ThisDrawing.Dictionaries("LISP-HATCH-DATA")
xrecord.Delete
BLAD:
End Function
|