Índice del Foro www.mediocad.com www.mediocad.com
TODO SOBRE MICROSTATION. MDL, MVBA, MACROS.
 
 F.A.Q.F.A.Q.   BuscarBuscar   Lista de MiembrosLista de Miembros   Grupos de UsuariosGrupos de Usuarios   RegístreseRegístrese 
 PerfilPerfil   Conéctese para revisar sus mensajesConéctese para revisar sus mensajes   ConectarseConectarse 

Implementar MDL en MVBA (mdlElement_getLineStyle)

 
Publicar Nuevo Tema   Responder al Tema    Índice del Foro www.mediocad.com -> Código MBVA
Ver tema anterior :: Ver siguiente tema  
Autor Mensaje
mediocad
Gran Maestro
Gran Maestro


Registrado: 09 Jun 2005
Mensajes: 1509
Ubicación: Madrid

MensajePublicado: Vie Ago 10, 2007 12:47 pm    Título del mensaje: Implementar MDL en MVBA (mdlElement_getLineStyle) Responder citando

Hola a todos,

En este post vamos a ver como implementamos las funciones de MDL en MVBA. Nos vamos a encontrar casos en que necesitemos obtener datos de algún elemento que las propias funciones o métodos de MVBA no lo tienen implementado.

En nuestro caso queremos saber el ancho inicial y final de una línea. Para orientaros, leer el post donde comenzó todo y comprenderéis el caso a tratar.

http://mediocad.com/phpBB2/viewtopic.php?t=2389

Vamos a trabajar con dos módulos y un módulo de clase. Los llamaremos Módulo1 (por defecto), modType y el de clase clsMSElementWrapper.

En Módulo1 copiamos el siguiente código:

Código:
Option Explicit

Private Declare Function mdlElement_getLineStyle Lib "stdmdlbltin.dll" (ByVal styleNameP As String, ByRef paramsP As MdlStyleParam, ByVal elementP As Long, ByVal modelRef As Long, ByVal lsIndex As Long) As Long

Sub buscar()

'Vbles. para escaneo
Dim ConjuntoElem    As ElementEnumerator
Dim oScanCriteria   As ElementScanCriteria
Dim oElement        As Element
Dim elemLine        As LineElement

'vbles para la MDL
Dim params As MdlStyleParam

On Error GoTo ErrorConsulta

  Set oScanCriteria = New ElementScanCriteria 'criterios de selección para el escaneo del DGN
  oScanCriteria.ExcludeAllTypes
  oScanCriteria.ExcludeNonGraphical
  oScanCriteria.IncludeType msdElementTypeLineString 'buscamos LineString

  Set ConjuntoElem = ActiveModelReference.Scan(oScanCriteria)
 
  ConjuntoElem.Reset
  Do While ConjuntoElem.MoveNext
    Set oElement = ConjuntoElem.Current
    If oElement.Type = msdElementTypeLineString Then
      Set elemLine = oElement
     
      GetElementLineStyleParams oElement, params 'llamada a la función que devuelve los parámetros
   
      Debug.Print "Valor Inicial= " & params.dStartWidth
      Debug.Print "Valor Final= " & params.dEndWidth

    End If
  Loop
 
ErrorConsulta:

'MsgBox Err.Description
'MsgBox Err.Number

End Sub

Sub GetElementLineStyleParams(ele As Element, styleParams As MdlStyleParam, Optional index As Long = 0)
Dim status As Long
Dim lModelRef As Long
Dim eleWrapped As New clsMSElementWrapper
   
  eleWrapped.SetReadOnlyPointer ele
   
  lModelRef = ele.ModelReference.MdlModelRefP
  status = mdlElement_getLineStyle(0, styleParams, eleWrapped.MSElementPtr, lModelRef, index)
End Sub

Al inicio declaramos la función MDL con la que vamos a trabajar. Luego tenemos un procedimiento llamado buscar() donde realizamos una búsqueda de las Line String de nuestro DGN. Y luego encontramos otro procedimiento GetElementLineStyleParams donde pasamos el elemento a encontrar para que nos devuelva los valores buscados.

En el módulo modType declaramos la estructura que recogerá los datos de los elementos y que simula la de MDL. Copiamos el siguiente código:

Código:
Option Explicit

Type MdlStyleParam
    lModifiers As Long
    lReserved As Long
    dScale As Double
    dDashScale As Double
    dGapScale As Double
    dStartWidth As Double
    dEndWidth As Double
    dDistPhase As Double
    dFractPhase As Double
    lLineMask As Long
    lMLineFlags As Long
    pntNormal As Point3d
    mtrxRotation As Matrix3d
End Type

Y en el módulo de clase clsMSElementWrapper copiar:

Código:
Option Explicit

Private Declare Sub mdlElmdscr_freeAll Lib "stdmdlbltin.dll" (ByRef elemDescr As Long)
Private Declare Function mdlElmdscr_replaceElement Lib "stdmdlbltin.dll" (ByRef existingDescrPP As Long, ByVal Element As Long) As Long

Private Declare Function ElmdscrAccessor_getMSElement Lib "stdmdlaccessor.dll" (ByVal ElementDescr As Long) As Long

Private Declare Sub CopyMemoryToVBA Lib "kernel32" Alias "RtlMoveMemory" _
  (ByRef VBALocation As Any, ByVal SourceLoc As Long, ByVal length As Long)
 
Private Declare Function mdlElement_size Lib "stdmdlbltin.dll" (ByVal el As Long) As Long

'
'   Private data
'
Private m_msEle() As Byte   ' Buffer to hold the MSElement
Private m_ele As Element    ' Object model Element
Private m_elDescr As Long
Private m_msElementPtr As Long  '  Points to the buffer or into the object model Element's element descriptor
'
'   Public Methods
'

Property Get MSElementPtr() As Long
  If m_msElementPtr = 0 Then
    Err.Raise &H80004005, "clsMSElementWrapper.MSElementPtr", "El objecto no contiene un puntero a un elemento"
  End If
  MSElementPtr = m_msElementPtr
End Property
'
'   It is rare that an increment value larger than 2000 is needed.
'
Sub SetReadWritePointer(ele As Element, Optional increment As Long = 2000)
    If Not m_ele Is Nothing Then
        Err.Raise &H80004005, "clsMSElementWrapper.SetReadWritePointer", "A program can only set a pointer once for any instance of clsMSElementWrapper"
    End If

    ExtractMSElement ele, increment
End Sub
Sub SetReadOnlyPointer(ele As Element)
    If Not m_ele Is Nothing Then
        Err.Raise &H80004005, "clsMSElementWrapper.SetReadOnlyPointer", "A program can only set a pointer once for any instance of clsMSElementWrapper"
    End If

    Set m_ele = ele
    m_msElementPtr = ElmdscrAccessor_getMSElement(ele.MdlElementDescrP)
End Sub
Sub ResetMSElement(Optional Save As Boolean = True)
    If Save And m_elDescr <> 0 Then
        If mdlElement_size(m_msElementPtr) >= UBound(m_msEle) Then
            Err.Raise &H80004005, "clsMSElementWrapper", "MSElement size exceeds array size"
        End If

        '
        '   Allocate an element descriptor large enough to hold the element
        '
        mdlElmdscr_replaceElement m_elDescr, m_msElementPtr
        '
        '   Associate that element descriptor with the Element object
        '
        m_ele.MdlSetElementDescrP m_elDescr
        m_elDescr = 0 ' Now the object model element owns it
    End If

    If m_elDescr <> 0 Then
        mdlElmdscr_freeAll m_elDescr
        m_elDescr = 0
    End If
    Set m_ele = Nothing
    m_msElementPtr = 0
End Sub

'
'   Private Methods
'
'
'   Copies the element into a buffer that is larger than the element
'   This is required for MDL functions that increase the size of the element
'
Private Sub ExtractMSElement(ele As Element, increment As Long)
    Dim pEle As Long
   
    If m_elDescr <> 0 Then
        mdlElmdscr_freeAll m_elDescr
    End If
    '
    '   Detach the element descriptor from the object model element.
    '   This clsMSElementWrapper object now owns the element descriptor
    '
    m_elDescr = ele.MdlElementDescrP(True)
    '
    '   Now allocate space for the MSElement and copy the element
    '   from the element descriptor
    '
    '
    pEle = ElmdscrAccessor_getMSElement(m_elDescr)
    ReDim m_msEle(0 To mdlElement_size(pEle) + increment)
    CopyMemoryToVBA m_msEle(0), pEle, mdlElement_size(pEle)
   
    '
    '   Save a reference to the object model element so we can
    '   set the element's element descriptor later
    '
    Set m_ele = ele
   
    '
    '   Save the pointer
    '
    m_msElementPtr = VarPtr(m_msEle(0))
End Sub
Private Sub Class_Terminate()
    If m_elDescr <> 0 Then
        '  Make the Element object useable again
        ResetMSElement True
    End If
End Sub


Este módulo requiere una explicación a parte porque trabaja con Descriptores, punteros y demás que se utiliza en MDL. Pero para su uso y funcionamiento os sirve. Si disponemos de tiempo intentaremos aclararlo un poco más.

Un saludo
Volver arriba
Ver perfil del usuario Enviar mensaje privado Enviar correo Visitar sitio web del autor
colocado



Registrado: 13 Dic 2016
Mensajes: 1

MensajePublicado: Mar Dic 13, 2016 2:49 pm    Título del mensaje: Responder citando

Es laborioso buscar gente con conocimientos sobre este tema, pero suena como si ya sabes de lo que estás hablando! Gracias
_________________
Tyję przez zaburzenia hormonalne ,bo niestety mam tarczyce ..
i jakie dobre tabletki na odchudzanie moge jeść?.?.?
Volver arriba
Ver perfil del usuario Enviar mensaje privado Visitar sitio web del autor
Mostrar mensajes anteriores:   
Publicar Nuevo Tema   Responder al Tema    Índice del Foro www.mediocad.com -> Código MBVA Todas las horas están en GMT + 1 Hora
Página 1 de 1

 
Saltar a:  
No puede crear mensajes
No puede responder temas
No puede editar sus mensajes
No puede borrar sus mensajes
No puede votar en encuestas


Powered by phpBB © 2001, 2005 phpBB Group