Colabora VB6

Manejar dibujos de AutoCAD en tus aplicaciones II

(Sin tener AutoCAD y ahora además puedes dibujar tus cosas)

 

Fecha: 13/Nov/2006 (12/11/2006)
Autor: ManelTB ([email protected])

 


Introducción

Tras la colaboración publicada el mes pasado y a petición de muchos de vosotros nos hemos liado un poco la manta a la cabeza y hemos decidido darle más capacidades al control para hacerlo versátil y potente. Además de corregir algunos pequeños bugs. Por cierto, ya he recibido el libro Visual Basic 2005 del Guille y debo decir que es totalmente recomendable y apto para todos los públicos.

 

Algunas de las mejoras del Control ActiveX MTBViewerX.ocx

La primera y principal es la capacidad para dibujar. Ahora disponemos de métodos para dibujar líneas, polilíneas, arcos, círculos, insertar bloques, textos y sombreados. También aporta capacidad para guardar dibujos con tus cambios así como nuevas propiedades. 

También he incorporado métodos como GetPoint() para obtener coordenadas haciendo clic sobre el dibujo, GetAngle() para obtener ángulos a partir de pares de puntos, etc. etc.

Por supuesto no es un control que pueda llegar a sustituir al genuino AutoCAD (que es la herramienta para dibujar planos), pero sí que te permitirá agregar información gráfica de forma fácil desde tu aplicación y guardarla en el dibujo.

A modo de recordatorio, éste es el aspecto del control en funcionamiento:

Este control ActiveX es gratuito para labores de investigación y desarrollo. Se trata de que lo descargues y lo pongas a prueba. Para facilitar las cosas se acompaña a este artículo la instalación de un programa que registrará todos los componentes que necesitas (en tu carpeta system32 \MTBViewerX\... los encontrarás copiados e instalados y podrás usarlo en tu aplicación). Con la instalación se acompaña el manual completo del control y también el proyecto en VB6 del programa para que puedas ver cómo se maneja el control.

El programa para poner a prueba el control ActiveX consiste en un formulario que contiene algunos de los comandos más relevantes. En él podrás comprobar cómo, mediante la obtención del nombre del dibujo y del ehandle de entidad de AutoCAD establecemos una relación biunívoca entre cada habitación y la persona o personas que la ocupan. Cada una de las habitaciones está representada mediante una polilínea (elige la combinación de capas polys) a la que se asocia el registro de la parrilla.

También encontrarás métodos para dibujar cosas en el dibujo y obtener listas de capas, referencias de bloque, etc.

El aspecto del programa para que podáis hacer vuestras pruebas es el siguiente:

Como puedes ver ahora hay bastantes más cosas para probar.

También he hecho cambios sobre el tema de las capas. Ahora se puede (casi se debe) establecer la capa de trabajo. La capa de trabajo se establece mediante la propiedad WorkLayer, o seleccionándola desde el formulario para la gestión de capas. Por supuesto, la capa de trabajo necesariamente a de ser una capa activa (On).

Por lo demás el aspecto del resto de componentes sigue siendo el mismo.

En el archivo con el código de ejemplo encontrarás, además de la instalación del programa de pruebas, que se encargará de instalar también los componentes, manual, etc., el proyecto en VB6 para que puedas ir siguiendo paso a paso cada una de las operaciones.

Si programas en .NET  también puedes incrustar MTBViewerX.ocx como un componente COM. VS.NET ya se encargará de generar automáticamente los ensamblados para que funcione sin (espero) problemas. En cualquier caso para eso pongo el control a disposición de la comunidad de programadores, para probar, detectar y corregir problemas.

Y ahora el código del formulario principal del programa de pruebas:

VERSION 5.00
Object = "{5E9E78A0-531B-11CF-91F6-C2863C385E30}#1.0#0"; "MSFLXGRD.OCX"
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Object = "{AF21F136-F180-419C-BCB6-549830E1DC44}#1.0#0"; "MTBViewerX.ocx"
Begin VB.Form Form1 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "MTBViewerX - Demo"
   ClientHeight    =   8805
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   10665
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   8805
   ScaleWidth      =   10665
   StartUpPosition =   3  'Windows Default
   Begin MTBViewerX_VS6.MTBViewerX MTBViewerX1 
      Height          =   4455
      Left            =   120
      TabIndex        =   64
      Top             =   60
      Width           =   7215
      _ExtentX        =   12726
      _ExtentY        =   7858
      IniLayerControl =   0   'False
   End
   Begin VB.Frame Frame2 
      Height          =   2475
      Left            =   7440
      TabIndex        =   35
      Top             =   6300
      Width           =   3195
      Begin VB.CommandButton btTodosTextos 
         Caption         =   "Todos textos"
         Height          =   315
         Left            =   1620
         TabIndex        =   43
         Top             =   540
         Width           =   1515
      End
      Begin VB.CommandButton btTematico 
         Caption         =   "Tamático"
         Height          =   315
         Left            =   60
         TabIndex        =   42
         Top             =   540
         Width           =   1515
      End
      Begin VB.CommandButton btDesenlazar 
         Caption         =   "Desenlazar"
         Height          =   315
         Left            =   1620
         TabIndex        =   41
         Top             =   180
         Width           =   1515
      End
      Begin VB.CheckBox chkTextoADibujo 
         Caption         =   "Poner texto al seleccionar"
         Height          =   255
         Left            =   240
         TabIndex        =   40
         Top             =   1860
         Value           =   1  'Checked
         Width           =   2835
      End
      Begin VB.OptionButton OpcHatch 
         Caption         =   "Remarcar con recuadro"
         Height          =   255
         Index           =   2
         Left            =   240
         TabIndex        =   39
         Top             =   1560
         Width           =   2835
      End
      Begin VB.OptionButton OpcHatch 
         Caption         =   "Remarcar con hatch si polylinea"
         Height          =   255
         Index           =   1
         Left            =   240
         TabIndex        =   38
         Top             =   1260
         Width           =   2835
      End
      Begin VB.OptionButton OpcHatch 
         Caption         =   "No remarcar al seleccionar"
         Height          =   255
         Index           =   0
         Left            =   240
         TabIndex        =   37
         Top             =   960
         Value           =   -1  'True
         Width           =   2835
      End
      Begin VB.CommandButton btEnlazar 
         Caption         =   "Enlazar"
         Height          =   315
         Left            =   60
         TabIndex        =   36
         Top             =   180
         Width           =   1515
      End
      Begin VB.Label lblTimeDWG 
         Height          =   255
         Left            =   1560
         TabIndex        =   46
         Top             =   2160
         Width           =   1455
      End
      Begin VB.Label Label5 
         Caption         =   "Tiempo de carga:"
         Height          =   255
         Left            =   240
         TabIndex        =   45
         Top             =   2160
         Width           =   1275
      End
   End
   Begin VB.Frame Frame1 
      Caption         =   "Propiedades y parámetros"
      Height          =   6255
      Left            =   7440
      TabIndex        =   8
      Top             =   0
      Width           =   3195
      Begin VB.TextBox txtXMLFile 
         Height          =   555
         Left            =   120
         MultiLine       =   -1  'True
         ScrollBars      =   2  'Vertical
         TabIndex        =   44
         Top             =   5520
         Width           =   2955
      End
      Begin VB.Label lblWorkLayer 
         BorderStyle     =   1  'Fixed Single
         Height          =   255
         Left            =   1740
         TabIndex        =   54
         Top             =   3900
         Width           =   1335
      End
      Begin VB.Label Label16 
         Caption         =   "Capa de trabajo:"
         Height          =   255
         Left            =   120
         TabIndex        =   53
         Top             =   3900
         Width           =   1515
      End
      Begin VB.Label lblRestSelActual 
         BorderStyle     =   1  'Fixed Single
         Height          =   255
         Left            =   1740
         TabIndex        =   52
         Top             =   3600
         Width           =   1335
      End
      Begin VB.Label Label15 
         Caption         =   "Rest. Sel.capa act."
         Height          =   255
         Left            =   120
         TabIndex        =   51
         Top             =   3600
         Width           =   1515
      End
      Begin VB.Label Label14 
         Caption         =   "Estilo de texto:"
         Height          =   255
         Left            =   120
         TabIndex        =   33
         Top             =   3300
         Width           =   1515
      End
      Begin VB.Label lblTextStyle 
         BorderStyle     =   1  'Fixed Single
         Height          =   255
         Left            =   1740
         TabIndex        =   32
         Top             =   3300
         Width           =   1335
      End
      Begin VB.Label Label13 
         Caption         =   "Ang. rotación textos:"
         Height          =   255
         Left            =   120
         TabIndex        =   31
         Top             =   3000
         Width           =   1515
      End
      Begin VB.Label lblTextRotation 
         BorderStyle     =   1  'Fixed Single
         Height          =   255
         Left            =   1740
         TabIndex        =   30
         Top             =   3000
         Width           =   1335
      End
      Begin VB.Label Label12 
         Caption         =   "Altura de los textos:"
         Height          =   255
         Left            =   120
         TabIndex        =   29
         Top             =   2700
         Width           =   1515
      End
      Begin VB.Label lblTextHeight 
         BorderStyle     =   1  'Fixed Single
         Height          =   255
         Left            =   1740
         TabIndex        =   28
         Top             =   2700
         Width           =   1335
      End
      Begin VB.Label Label11 
         Caption         =   "Color de los textos:"
         Height          =   255
         Left            =   120
         TabIndex        =   27
         Top             =   2400
         Width           =   1515
      End
      Begin VB.Label lblTextColor 
         BorderStyle     =   1  'Fixed Single
         Height          =   255
         Left            =   1740
         TabIndex        =   26
         Top             =   2400
         Width           =   1335
      End
      Begin VB.Label Label10 
         Caption         =   "Decimales coord.:"
         Height          =   255
         Left            =   120
         TabIndex        =   25
         Top             =   900
         Width           =   1515
      End
      Begin VB.Label lblDecimales 
         BorderStyle     =   1  'Fixed Single
         Height          =   255
         Left            =   1740
         TabIndex        =   24
         Top             =   900
         Width           =   1335
      End
      Begin VB.Label Label9 
         Caption         =   "Alineación textos:"
         Height          =   255
         Left            =   120
         TabIndex        =   23
         Top             =   2100
         Width           =   1515
      End
      Begin VB.Label lblTextAlign 
         BorderStyle     =   1  'Fixed Single
         Height          =   255
         Left            =   1740
         TabIndex        =   22
         Top             =   2100
         Width           =   1335
      End
      Begin VB.Label Label8 
         Caption         =   "Color de sombreado:"
         Height          =   255
         Left            =   120
         TabIndex        =   21
         Top             =   1800
         Width           =   1515
      End
      Begin VB.Label lblHatchColor 
         BorderStyle     =   1  'Fixed Single
         Height          =   255
         Left            =   1740
         TabIndex        =   20
         Top             =   1800
         Width           =   1335
      End
      Begin VB.Label Label7 
         Caption         =   "Hatch a entidad act:"
         Height          =   255
         Left            =   120
         TabIndex        =   19
         Top             =   1500
         Width           =   1515
      End
      Begin VB.Label lblHatchAEntidad 
         BorderStyle     =   1  'Fixed Single
         Height          =   255
         Left            =   1740
         TabIndex        =   18
         Top             =   1500
         Width           =   1335
      End
      Begin VB.Label lblFactorZoom 
         BorderStyle     =   1  'Fixed Single
         Height          =   255
         Left            =   1740
         TabIndex        =   17
         Top             =   600
         Width           =   1335
      End
      Begin VB.Label lblZoomAEntidad 
         BorderStyle     =   1  'Fixed Single
         Height          =   255
         Left            =   1740
         TabIndex        =   16
         Top             =   1200
         Width           =   1335
      End
      Begin VB.Label Label1 
         Alignment       =   2  'Center
         BorderStyle     =   1  'Fixed Single
         Caption         =   "Ruta archivos XML y PRM"
         Height          =   255
         Left            =   120
         TabIndex        =   15
         Top             =   5220
         Width           =   2955
      End
      Begin VB.Label lblDwgVersion 
         BorderStyle     =   1  'Fixed Single
         Height          =   255
         Left            =   120
         TabIndex        =   14
         Top             =   4920
         Width           =   2955
      End
      Begin VB.Label Label3 
         Alignment       =   2  'Center
         BorderStyle     =   1  'Fixed Single
         Caption         =   "Versión de dibujo AutoCAD"
         Height          =   255
         Left            =   120
         TabIndex        =   13
         Top             =   4620
         Width           =   2955
      End
      Begin VB.Label Label2 
         Caption         =   "Factor de zoom:"
         Height          =   255
         Left            =   120
         TabIndex        =   12
         Top             =   600
         Width           =   1515
      End
      Begin VB.Label Label4 
         Caption         =   "Zoom a entidad act:"
         Height          =   255
         Left            =   120
         TabIndex        =   11
         Top             =   1200
         Width           =   1515
      End
      Begin VB.Label lblVersionX 
         Height          =   255
         Left            =   720
         TabIndex        =   10
         Top             =   300
         Width           =   2355
      End
      Begin VB.Label Label6 
         Caption         =   "Versión:"
         Height          =   255
         Left            =   120
         TabIndex        =   9
         Top             =   300
         Width           =   675
      End
   End
   Begin VB.Frame Metodos 
      Caption         =   "Métodos para MTBViewerX"
      Height          =   1995
      Left            =   120
      TabIndex        =   1
      Top             =   6780
      Width           =   7275
      Begin VB.CommandButton btSaveAS 
         Caption         =   "Guardar como"
         Height          =   375
         Left            =   5820
         TabIndex        =   48
         Top             =   1500
         Width           =   1395
      End
      Begin VB.CommandButton btSaveDWG 
         Caption         =   "Guardar dibujo"
         Height          =   375
         Left            =   4380
         TabIndex        =   63
         Top             =   1500
         Width           =   1395
      End
      Begin VB.CommandButton btGetListBlk 
         Caption         =   "Get List BlkRef"
         Height          =   375
         Left            =   2940
         TabIndex        =   62
         Top             =   1500
         Width           =   1395
      End
      Begin VB.CommandButton btGetListLayers 
         Caption         =   "Get List Layers"
         Height          =   375
         Left            =   1500
         TabIndex        =   61
         Top             =   1500
         Width           =   1395
      End
      Begin VB.CommandButton btAddBlock 
         Caption         =   "Add Block"
         Height          =   375
         Left            =   60
         TabIndex        =   60
         Top             =   1500
         Width           =   1395
      End
      Begin VB.CommandButton btAddArc 
         Caption         =   "Add Arc"
         Height          =   375
         Left            =   5820
         TabIndex        =   59
         Top             =   1080
         Width           =   1395
      End
      Begin VB.CommandButton btAddCircle 
         Caption         =   "Add Circle"
         Height          =   375
         Left            =   4380
         TabIndex        =   58
         Top             =   1080
         Width           =   1395
      End
      Begin VB.CommandButton btAddPolyline 
         Caption         =   "Add polyline"
         Height          =   375
         Left            =   2940
         TabIndex        =   57
         Top             =   1080
         Width           =   1395
      End
      Begin VB.CommandButton btDeleteEnt 
         Caption         =   "Delete entity"
         Height          =   375
         Left            =   1500
         TabIndex        =   56
         Top             =   1080
         Width           =   1395
      End
      Begin VB.CommandButton btAddText 
         Caption         =   "Add Text"
         Height          =   375
         Left            =   60
         TabIndex        =   55
         Top             =   1080
         Width           =   1395
      End
      Begin VB.CommandButton bt_AddHatch 
         Caption         =   "Add Hatch"
         Height          =   375
         Left            =   5820
         TabIndex        =   50
         Top             =   660
         Width           =   1395
      End
      Begin VB.CommandButton bt_AddLine 
         Caption         =   "Add Line"
         Height          =   375
         Left            =   4380
         TabIndex        =   49
         Top             =   660
         Width           =   1395
      End
      Begin VB.CommandButton bt_GetPoint 
         Caption         =   "Get Point"
         Height          =   375
         Left            =   2940
         TabIndex        =   47
         Top             =   660
         Width           =   1395
      End
      Begin VB.CommandButton btAreaPerimetro 
         Caption         =   "Área y Perímetro"
         Height          =   375
         Left            =   1500
         TabIndex        =   34
         Top             =   660
         Width           =   1395
      End
      Begin VB.CommandButton btOpenDWG 
         Caption         =   "Abrir dibujo"
         Height          =   375
         Left            =   60
         TabIndex        =   7
         Top             =   240
         Width           =   1395
      End
      Begin VB.CommandButton btCloseDWG 
         Caption         =   "Cerrar dibujo"
         Height          =   375
         Left            =   1500
         TabIndex        =   6
         Top             =   240
         Width           =   1395
      End
      Begin VB.CommandButton btAgregarTxt 
         Caption         =   "Texto virtual"
         Height          =   375
         Left            =   4380
         TabIndex        =   5
         Top             =   240
         Width           =   1395
      End
      Begin VB.CommandButton btEliminarLastTxt 
         Caption         =   "borra ultimo texto"
         Height          =   375
         Left            =   2940
         TabIndex        =   4
         Top             =   240
         Width           =   1395
      End
      Begin VB.CommandButton btEliminarAllTxt 
         Caption         =   "Del. Textos virt."
         Height          =   375
         Left            =   5820
         TabIndex        =   3
         Top             =   240
         Width           =   1395
      End
      Begin VB.CommandButton btHatch 
         Caption         =   "Sombreado virtual"
         Height          =   375
         Left            =   60
         TabIndex        =   2
         Top             =   660
         Width           =   1395
      End
   End
   Begin MSFlexGridLib.MSFlexGrid Flex 
      Height          =   2175
      Left            =   120
      TabIndex        =   0
      Top             =   4560
      Width           =   7215
      _ExtentX        =   12726
      _ExtentY        =   3836
      _Version        =   393216
      Cols            =   7
      FixedCols       =   0
      FocusRect       =   2
      SelectionMode   =   1
      AllowUserResizing=   1
      FormatString    =   $"Form1.frx":0000
   End
   Begin MSComDlg.CommonDialog OpenDwg 
      Left            =   6960
      Top             =   6420
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Comando As String
Private IsDWGOpen As Boolean
Private LastRow As Integer

Private Sub bt_AddHatch_Click()
    Dim MtrEnts() As String
    Dim k As Integer
    Dim e As String
    k = 0
    Comando = "ADDHATCH"
    ReDim MtrEnts(0)
    e = Me.MTBViewerX1.SelectEnt
    Do While e <> ""
        ReDim Preserve MtrEnts(k)
        MtrEnts(k) = e
        k = k + 1
        e = Me.MTBViewerX1.SelectEnt
    Loop
    For k = LBound(MtrEnts) To UBound(MtrEnts)
        If MtrEnts(k) <> "" Then
            Me.MTBViewerX1.AddHatch MtrEnts(k), k + 1
        End If
    Next k
End Sub

Private Sub bt_AddLine_Click()
    Dim Pt1 As Variant
    Dim Pt2 As Variant
    Dim sHandle As String
    Pt1 = Me.MTBViewerX1.GetPoint(acNone, "Indique punto inicial...")
    If IsArray(Pt1) Then
        Pt2 = Me.MTBViewerX1.GetPoint(acLine, "Indique punto final...", Pt1)
        If IsArray(Pt2) Then
            If Me.MTBViewerX1.AddLine(sHandle, Pt1(0), Pt1(1), Pt1(2), _
            Pt2(0), Pt2(1), Pt2(2)) = True Then
                MsgBox "Linea creada"
            Else
                MsgBox "fallo"
            End If
        End If
    End If
    Comando = "ADDLINE"
End Sub

Private Sub bt_GetPoint_Click()
    Dim Pt As Variant
    Dim sMsg As String
    Pt = Me.MTBViewerX1.GetPoint(acNone, "Haga clic en la pantalla... ")
    If IsArray(Pt) Then
        sMsg = "Punto seleccionado: " & Chr(13) & _
                      "x = " & Pt(0) & Chr(13) & _
                                    "y = " & Pt(1)
    Else
        sMsg = "No se seleccionó ningún punto"
    End If
    MsgBox sMsg, vbOKOnly + vbInformation, "GetPoint"
End Sub

Private Sub btAddArc_Click()
    Dim m As Variant
    Dim m1 As Variant
    Dim PtCen(2) As Double
    Dim PtIni(2) As Double
    Dim PtAng(2) As Double
    Dim Ang1 As Double
    Dim Ang2 As Double
    Dim Rad As Double
    Dim sHandle As String    
    m = Me.MTBViewerX1.GetPoint(acNone, "Indique centro del arco... ")
    If IsArray(m) Then
        PtCen(0) = m(0)
        PtCen(1) = m(1)
        PtCen(2) = m(2)       
        m1 = m
        m = Me.MTBViewerX1.GetPoint(acLine, "Punto inicial del arco... ", m)
        If IsArray(m) Then
            PtIni(0) = m(0)
            PtIni(1) = m(1)
            PtIni(2) = m(2)
            Ang1 = Me.MTBViewerX1.GetAngle(PtCen, PtIni, False)
            Rad = Me.MTBViewerX1.CalcularDistancia( _
			PtCen(0), PtCen(1), PtIni(0), PtIni(1))
            m = Me.MTBViewerX1.GetPoint(acLine, "Indicar ángulo...", m1)
            If IsArray(m) Then
                PtAng(0) = m(0)
                PtAng(1) = m(1)
                PtAng(2) = m(2)
                Ang2 = Me.MTBViewerX1.GetAngle(PtCen, PtAng, False)
                If Me.MTBViewerX1.AddArc(sHandle, PtCen(0), PtCen(1), PtCen(2), _
                                         Rad, Ang1, Ang2) = True Then
                    MsgBox "Arco creado"
                Else
                    MsgBox "Error al crear el arco"
                End If
            Else
                MsgBox "No se obtuvo el ángulo del arco"
            End If
        Else
            MsgBox "No se obtuvo el punto inicial del arco"
        End If
    Else
        MsgBox "No se obtuvo el centro del arco"
    End If
    Comando = "ADDARC"
End Sub

Private Sub btAddBlock_Click()
    Dim s As Variant
    Dim i As Integer
    Dim T As Boolean
    Dim Fitxer As String
    Dim Fitxer1 As String
    Dim BlkName As String
    Dim PtInsert(2) As Double
    Dim ScX As Double
    Dim ScY As Double
    Dim ScZ As Double
    Dim Rotation As Double
    Dim m As Variant
    Dim sHandle As String    
    BlkName = InputBox("Indicar nombre del bloque a insertar", "Insertar bloque")
    If BlkName = "" Then Exit Sub
    If Me.MTBViewerX1.ExistBlkRef(Trim(BlkName)) = True Then
        m = Me.MTBViewerX1.GetPoint(acNone, "Punto de inserción...")
        If IsArray(m) Then
            PtInsert(0) = m(0)
            PtInsert(1) = m(1)
            PtInsert(2) = m(2)
            ScX = CDbl(InputBox("Factor de Escala para X:", "Insertar bloque", "1"))
            ScY = CDbl(InputBox("Factor de Escala para Y:", "Insertar bloque", _
				CStr(ScX)))
            ScZ = 1
            Rotation = Me.MTBViewerX1.DegToRad( _
		CDbl(InputBox("Ángulo de rotación:", "Insertar bloque", "0")))
            If Me.MTBViewerX1.InsertBlock(sHandle, BlkName, _
                                          PtInsert(0), PtInsert(1), PtInsert(2), _
                                          ScX, ScY, ScZ, Rotation) = True Then
                MsgBox "Bloque insertado"
            Else
                MsgBox "Falló la inserción del bloque"
            End If
        Else
            MsgBox "No se obtuvo punto de inserción"
        End If
    Else
        If MsgBox("La referencia de bloque '" & BlkName & _
                  "' no existe en el dibujo." & Chr(13) & _
                  "¿Desea insertar un archivo externo?", vbQuestion + vbYesNo, _
                  "Insertar bloque") = vbYes Then
            Me.OpenDwg.DialogTitle = "Seleccionar archivo a insertar"
            Me.OpenDwg.Action = 1
            Fitxer = Me.OpenDwg.FileName
            If Trim(Fitxer) <> "" Then
                BlkName = Me.MTBViewerX1.InsertDwgRefBlock(Fitxer)
                If BlkName <> "" Then
                    'Se obtuvo la inserción de la nueva referencia de bloque
                    m = Me.MTBViewerX1.GetPoint(acNone, "Punto de inserción...")
                    If IsArray(m) Then
                        PtInsert(0) = m(0)
                        PtInsert(1) = m(1)
                        PtInsert(2) = m(2)
                        ScX = InputBox("Factor de Escala para X:", _
					"Insertar bloque", 1)
                        ScY = InputBox("Factor de Escala para Y:", _
					"Insertar bloque", ScX)
                        ScZ = 1
                        Rotation = InputBox("Ángulo de rotación:", _
						"Insertar bloque", 0)
                        If Me.MTBViewerX1.InsertBlock(sHandle, BlkName, _
                                              PtInsert(0), PtInsert(1), _
					      PtInsert(2), _
                                              ScX, ScY, ScZ, Rotation) = True Then
                            MsgBox "Bloque insertado"
                        Else
                            MsgBox "Falló la inserción del bloque"
                        End If
                    Else
                        MsgBox "No se obtuvo punto de inserción"
                    End If
                Else
                    MsgBox "No se consiguió añadir la referencia de bloque para " & _
				Fitxer
                End If
            Else
                MsgBox "No se seleccionó ningun archivo"
            End If
        End If
    End If
    Comando = "INSERTBLOCK"
End Sub

Private Sub btAddCircle_Click()
    Dim m As Variant
    Dim PtCen(2) As Double
    Dim PtRad(2) As Double
    Dim R As Double
    Dim sHandle As String    
    m = Me.MTBViewerX1.GetPoint(acNone, "Indique el centro del círculo... ")
    If IsArray(m) Then
        PtCen(0) = m(0)
        PtCen(1) = m(1)
        PtCen(2) = m(2)
        m = Me.MTBViewerX1.GetPoint(acLine, "Indique radio... ", m)
        If IsArray(m) Then
            PtRad(0) = m(0)
            PtRad(1) = m(1)
            PtRad(2) = m(2)
            R = Me.MTBViewerX1.CalcularDistancia(PtCen(0), PtCen(1), PtRad(0), _
				PtRad(1))
            If R > 0 Then
                If Me.MTBViewerX1.AddCircle( _
			sHandle, PtCen(0), PtCen(1), PtCen(2), R) = True Then
                    MsgBox "Círculo creado"
                Else
                    MsgBox "No se pudo crear el círculo"
                End If
            Else
                MsgBox "No se puede dibujar un círculo de radio 0"
            End If
        End If
        Comando = "ADDCIRCLE"
    End If    
End Sub

Private Sub btAddPolyline_Click()
    Dim m As Variant
    Dim PtIni(2) As Double
    Dim PtFin(2) As Double
    Dim ArrTmp() As Double
    Dim ArrPts() As Variant 'Array de puntos
    Dim ArrHdl() As String  'Array de lineas temporales
    Dim ArrPoly() As Double
    Dim vPoly As Variant
    Dim sHandle As String
    Dim HandlePol As String
    Dim ArrP() As Double   
    Dim i As Integer
    Dim j As Integer
    Dim k As Integer
    Dim s As Integer
    m = Me.MTBViewerX1.GetPoint(acNone, "Indique primer punto... ")
    s = 0
    If IsArray(m) Then  'Disponemos del primer punto
        PtIni(0) = m(0)
        PtIni(1) = m(1)
        PtIni(2) = m(2)
        Do While True
            m = Me.MTBViewerX1.GetPoint(acLine, "Indique siguiente punto... ", m)
            If IsArray(m) Then 'Hay punto siguiente
                PtFin(0) = m(0)
                PtFin(1) = m(1)
                PtFin(2) = m(2)
                ReDim ArrTmp(1) 'Preparar la matriz con los puntos de las polilíneas
                'Punto inicial
                ArrTmp(0) = PtIni(0)
                ArrTmp(1) = PtIni(1)
                ReDim Preserve ArrPts(s)
                ArrPts(s) = ArrTmp
                s = s + 1
                'Punto final
                ReDim ArrTmp(1)
                ArrTmp(0) = PtFin(0)
                ArrTmp(1) = PtFin(1)
                ReDim Preserve ArrPts(s)
                ArrPts(s) = ArrTmp
                s = s + 1
                'Agregar la línea
                If Me.MTBViewerX1.AddLine(sHandle, _
                                          PtIni(0), PtIni(1), PtIni(2), _
                                          PtFin(0), PtFin(1), PtFin(2)) = True Then
                    ReDim Preserve ArrHdl(k) 'Lista de handles para líneas virtuales
                    ArrHdl(k) = sHandle
                    k = k + 1
                End If
                'Preparar para la siguiente línea
                PtIni(0) = PtFin(0)
                PtIni(1) = PtFin(1)
                PtIni(2) = PtFin(2)
                m = PtIni
            Else
                Exit Do
            End If
        Loop
    End If
    If s > 1 Then 'Se guardaron puntos
        'Preparar la matriz de vertices para la polilinea
        ReDim ArrP(UBound(ArrPts), 1)
        For i = LBound(ArrPts) To UBound(ArrPts)
            For s = LBound(ArrPts(i)) To UBound(ArrPts(i))
                ArrP(i, s) = ArrPts(i)(s)
            Next s
        Next i        
        'ArrP ha de ser un tipo bidimensional ArrP(n,m)            
        vPoly = ArrP        
        'Eliminar las líneas virtuales creadas
        For i = LBound(ArrHdl) To UBound(ArrHdl)
            Me.MTBViewerX1.DeleteEntity ArrHdl(i)
        Next i
        'Dibujar la polilínea
        'Eliminar vacios
        If Me.MTBViewerX1.AddPolyline(HandlePol, vPoly) = True Then
            MsgBox "Polilínea creada"
        Else
            MsgBox "Falló la creación de la polilínea"
        End If
    Else
        MsgBox "No se obtuvieron puntos"
    End If
    Comando = "ADDPOLYLINE"    
End Sub

Private Sub btAddText_Click()
    Dim m As Variant
    Dim s As String
    m = Me.MTBViewerX1.GetPoint(acNone, "Click donde insertar texto...")
    If Not IsEmpty(m) Then
        s = InputBox("Escriba el texto a insertar", "Agregar texto")
        If s <> "" Then
            Me.MTBViewerX1.AddText m(0), m(1), s, "|"
        End If
    End If
    Comando = "ADDTEXT"
End Sub

Private Sub btAgregarTxt_Click()
    Dim myText As String
    Dim e As String
    Dim sx As Double
    Dim sy As Double
    e = Me.MTBViewerX1.SelectEnt
    If e <> "" Then
        If Me.MTBViewerX1.GetCentroid(e, sx, sy) = True Then
            'Me.MTBViewerX1.DeleteLastText
            myText = "Area: " & Me.MTBViewerX1.GetBoundArea(e) & _
                     "|" & "Perímetro: " & _
                     Me.MTBViewerX1.GetBoundPerimeter(e)
            Me.MTBViewerX1.AddVirtualText sx, sy, myText, "|"
        End If
    End If
    Comando = "ADDVIRTUALTEXT"
End Sub

Private Sub btAreaPerimetro_Click()
    Comando = "AREA&PERIMETRO"
    Me.MTBViewerX1.SelectEnt
End Sub

Private Sub btCloseDWG_Click()
    Me.MTBViewerX1.DwgClose
    Me.lblDwgVersion.Caption = ""
    Me.txtXMLFile.Text = ""
    Me.lblFactorZoom.Caption = ""
    Me.lblZoomAEntidad.Caption = ""
End Sub

Private Sub btDeleteEnt_Click()
    Me.MTBViewerX1.DeleteEntity
End Sub

Private Sub btDesenlazar_Click()
    Comando = "DESENLAZAR"
    Me.MTBViewerX1.SelectEnt    
End Sub

Private Sub btEliminarAllTxt_Click()
    Me.MTBViewerX1.DeleteAllTexts
End Sub

Private Sub btEliminarLastTxt_Click()
    Me.MTBViewerX1.DeleteLastText
End Sub

Private Sub btEnlazar_Click()
    Comando = "ENLAZAR"
    Me.MTBViewerX1.SelectEnt    
End Sub

Private Sub btGetListBlk_Click()
    Dim m As Variant
    Dim msg As String
    Dim i As Integer
    m = Me.MTBViewerX1.GetListBlkRef
    If IsArray(m) Then
        For i = LBound(m) To UBound(m)
            msg = msg & m(i) & Chr(13)
        Next i
        MsgBox msg, vbOKOnly, "Lista de boques"
    Else
        MsgBox "No se obtuvieron referencias de bloques"
    End If
End Sub

Private Sub btGetListLayers_Click()
    Dim m As Variant
    Dim msg As String
    Dim i As Integer
    Dim j As Integer
    m = Me.MTBViewerX1.GetListLayers
    If IsArray(m) Then
        For i = LBound(m) To UBound(m)
            For j = LBound(m(i)) To UBound(m(i))
                If j = UBound(m(i)) Then
                    msg = msg & m(i)(j)
                Else
                    msg = msg & m(i)(j) & "|"
                End If
            Next j
            msg = msg & Chr(13)
        Next i
        MsgBox msg, vbOKOnly, "Lista de capas del dibujo"
    Else
        MsgBox "No se obtuvo la lista de capas"
    End If    
End Sub

Private Sub btHatch_Click()
    Dim MtrEnts() As String
    Dim k As Integer
    Dim e As String
    k = 0
    Comando = "ADDVIRTUALHATCH"
    ReDim MtrEnts(0)
    e = Me.MTBViewerX1.SelectEnt
    Do While e <> ""
        ReDim Preserve MtrEnts(k)
        MtrEnts(k) = e
        k = k + 1
        e = Me.MTBViewerX1.SelectEnt
    Loop
    For k = LBound(MtrEnts) To UBound(MtrEnts)
        If MtrEnts(k) <> "" Then
            Me.MTBViewerX1.AddVirtualHatch MtrEnts(k), k + 1
        End If
    Next k
End Sub

Private Sub btOpenDWG_Click()
    Dim Fitxer As String
    Dim t1 As Date
    Dim t2 As Date
    On Error Resume Next    
    Err.Clear
    Me.lblTimeDWG.Caption = ""
    Me.OpenDwg.CancelError = True
    Me.OpenDwg.FileName = "*.dwg"
    Me.OpenDwg.ShowOpen
    If Err.Number <> 0 Then
        Exit Sub
    End If
    Me.MTBViewerX1.SetUnlockKey ("Put your key code")
    Me.MTBViewerX1.FactorZoom = 0.8
    Me.MTBViewerX1.ZoomAEntidad = False
    Fitxer = Me.OpenDwg.FileName
    t1 = Time    
    If Me.MTBViewerX1.OpenDwg(Fitxer) Then
        t2 = Time
        Me.lblTimeDWG.Caption = CStr(DateDiff("s", t1, t2)) & " segundos."
        Me.lblDwgVersion.Caption = Me.MTBViewerX1.DwgVersion
        Me.txtXMLFile.Text = Me.MTBViewerX1.XMLFile & vbCrLf
        Me.txtXMLFile.Text = Me.txtXMLFile.Text & Me.MTBViewerX1.PRMFile
        Me.lblFactorZoom.Caption = Me.MTBViewerX1.FactorZoom
        CargarParametros
    Else
        MsgBox "Falló la apertura del archivo " & Fitxer
        Me.lblDwgVersion.Caption = ""
        Me.txtXMLFile.Text = ""
        ResetParametros
    End If
    IsDWGOpen = True
    Comando = "OPEN"
End Sub

Private Sub CargarParametros()    
    Me.lblZoomAEntidad.Caption = Me.MTBViewerX1.GetParams_ZoomToEntity
    Me.lblHatchAEntidad.Caption = Me.MTBViewerX1.GetParams_HatchEntity
    Me.lblHatchColor.Caption = Me.MTBViewerX1.GetParams_HatchColor
    Me.lblTextAlign.Caption = Me.MTBViewerX1.GetParams_TextAlign
    Me.lblDecimales.Caption = Me.MTBViewerX1.GetParams_DecimalsCoords
    Me.lblTextColor.Caption = Me.MTBViewerX1.GetParams_TextColor
    Me.lblTextHeight.Caption = Me.MTBViewerX1.GetParams_TextHeight
    Me.lblTextRotation.Caption = Me.MTBViewerX1.GetParams_TextRotation
    Me.lblTextStyle.Caption = Me.MTBViewerX1.GetParams_TextStyle
    Me.lblRestSelActual.Caption = Me.MTBViewerX1.RestrictSelInWorkLayer
    Me.lblWorkLayer.Caption = Me.MTBViewerX1.WorkLayer
End Sub

Private Sub ResetParametros()
    Me.lblZoomAEntidad.Caption = ""
    Me.lblHatchAEntidad.Caption = ""
    Me.lblHatchColor.Caption = ""
    Me.lblTextAlign.Caption = ""
    Me.lblDecimales.Caption = ""
    Me.lblTextColor.Caption = ""
    Me.lblTextHeight.Caption = ""
    Me.lblTextRotation.Caption = ""
    Me.lblTextStyle.Caption = ""
End Sub

Private Sub CargarGrid()
    Dim Cadenas(5) As String
    Dim i As Integer
    Cadenas(0) = "001" & vbTab & "Juan Palomo" & vbTab & _
                 "Contabilidad" & vbTab & "oficinas1.dwg" & vbTab & _
                 "2E53" & vbTab & "AcDbPolyline" & vbTab & "1"
    Cadenas(1) = "002" & vbTab & "Juan Miralles" & vbTab & _
                 "Tecnico" & vbTab & "oficinas1.dwg" & vbTab & _
                 "2CF7" & vbTab & "AcDbPolyline" & vbTab & "22"
    Cadenas(2) = "003" & vbTab & "Marga López" & vbTab & _
                 "Comunicaciones" & vbTab & "oficinas1.dwg" & vbTab & _
                 "2CD6" & vbTab & "AcDbPolyline" & vbTab & "33"
    Cadenas(3) = "004" & vbTab & "Lucía Pérez" & vbTab & _
                 "Comunicaciones" & vbTab & "oficinas1.dwg" & vbTab & _
                 "2CDC" & vbTab & "AcDbPolyline" & vbTab & "44"
    Cadenas(4) = "005" & vbTab & "Casimiro Toloveo" & vbTab & _
                 "Dirección" & vbTab & "oficinas1.dwg" & vbTab & _
                 "2CC6" & vbTab & "AcDbPolyline" & vbTab & "55"
    Cadenas(5) = "006" & vbTab & "Rocío Madrid" & vbTab & _
                 "Coordinación" & vbTab & "oficinas1.dwg" & vbTab & _
                 "2CFD" & vbTab & "AcDbPolyline" & vbTab & "66"
    Me.Flex.Rows = 1
    For i = LBound(Cadenas) To UBound(Cadenas)
        Me.Flex.AddItem Cadenas(i)
    Next i
End Sub

Private Sub btSaveDWG_Click()
    If Me.MTBViewerX1.SaveDWG(Me.MTBViewerX1.DwgPath & "\" _
                             & Me.MTBViewerX1.DwgName) = True Then
        MsgBox "Dibujo guardado en versión " & Me.MTBViewerX1.DwgVersion
    Else
        MsgBox "Falló el guardado del dibujo"
    End If    
End Sub

Private Sub btTematico_Click()
    Dim i As Integer
    Dim tx As String
    Dim d As String
    Dim e As String
    Dim h As String
    Dim c As Integer
    Dim sx As Double
    Dim sy As Double
    Me.MTBViewerX1.Refresh
    For i = 1 To Me.Flex.Rows - 1
        d = Me.Flex.TextMatrix(i, 3)
        h = Me.Flex.TextMatrix(i, 4)
        e = Me.Flex.TextMatrix(i, 5)
        c = Me.Flex.TextMatrix(i, 6)
        tx = Me.Flex.TextMatrix(i, 0) & "|" & _
             Me.Flex.TextMatrix(i, 1) & "|" & _
             Me.Flex.TextMatrix(i, 2)
        If d = Me.MTBViewerX1.DwgName Then
            If e = "AcDbPolyline" Or e = "AcDb2dPolyline" Then
                If Me.MTBViewerX1.AddVirtualHatch(h, c) = False Then
                    MsgBox "Falló el intento de sombrear", _
			vbOKOnly + vbInformation, "Demo"
                    Exit Sub
                End If
            End If
            If Me.MTBViewerX1.GetCentroid(h, sx, sy) = True Then
                Me.MTBViewerX1.AddVirtualText sx, sy, tx, "|"
            End If
        End If
    Next i
End Sub

Private Sub btTodosTextos_Click()
    Dim i As Integer
    Dim tx As String
    Dim d As String
    Dim e As String
    Dim h As String
    Dim c As Integer
    Dim sx As Double
    Dim sy As Double
    Me.MTBViewerX1.Redraw
    For i = 1 To Me.Flex.Rows - 1
        d = Me.Flex.TextMatrix(i, 3)
        h = Me.Flex.TextMatrix(i, 4)
        e = Me.Flex.TextMatrix(i, 5)
        c = Me.Flex.TextMatrix(i, 6)
        tx = Me.Flex.TextMatrix(i, 0) & "|" & _
             Me.Flex.TextMatrix(i, 1) & "|" & _
             Me.Flex.TextMatrix(i, 2)
        If d = Me.MTBViewerX1.DwgName Then
            If Me.MTBViewerX1.GetCentroid(h, sx, sy) = True Then
                Me.MTBViewerX1.AddVirtualText sx, sy, tx, "|"
            End If
        End If
    Next i
End Sub

Private Sub btSaveAS_Click()
    On Local Error Resume Next
    Me.OpenDwg.DialogTitle = "Guardar el dibujo "
    Me.OpenDwg.DefaultExt = "dwg"
    Me.OpenDwg.Filter = "Dibujos de AutoCAD (*.dwg)|*.dwg"
    Me.OpenDwg.ShowSave
    If Me.OpenDwg.FileName <> "" Then
        If Me.MTBViewerX1.SaveDWG(Me.OpenDwg.FileName, Actual) = True Then
            MsgBox "Dibujo guardado"
        Else
            MsgBox "Error al guardar el dibujo"
        End If
    End If
End Sub

Private Sub Flex_DblClick()
    Dim d As New ColorDlgACI.ColorDlg
    If Me.Flex.Row >= 1 Then
        d.ColorACI = Me.Flex.TextMatrix(Me.Flex.Row, 6)
        d.ShowColorDlg
        Me.Flex.TextMatrix(Me.Flex.Row, 6) = d.ColorACI
    End If
    Set d = Nothing
    
End Sub

Private Sub Flex_EnterCell()
    Dim tx As String
    Dim e As String
    Dim d As String
    Dim h As String
    Dim sx As Double
    Dim sy As Double
    If IsDWGOpen = False Then Exit Sub
    d = Me.Flex.TextMatrix(Me.Flex.Row, 3)  'Nombre del dibujo
    h = Me.Flex.TextMatrix(Me.Flex.Row, 4)  'Handle de entidad
    e = Me.Flex.TextMatrix(Me.Flex.Row, 5)  'Tipo de entidad
    If LastRow <> Me.Flex.Row Then
        Me.MTBViewerX1.Redraw
        If d = Me.MTBViewerX1.DwgName Then 'Se trata del mismo dibujo
            'Si hay que señalar la polilínea con un sombreado...
            If Me.OpcHatch(1).Value = True Then
                If e = "AcDbPolyline" Or e = "AcDb2dPolyline" Then
                    Me.MTBViewerX1.AddVirtualHatch h, _
			Me.MTBViewerX1.GetParams_HatchColor
                Else
                    Me.MTBViewerX1.ColorSelectBox = 2
                    Me.MTBViewerX1.BoxToEntity h
                End If
            Else
                If Me.OpcHatch(2).Value = True Then
                    Me.MTBViewerX1.ColorSelectBox = 2
                    Me.MTBViewerX1.BoxToEntity h
                End If
            End If
            If Me.chkTextoADibujo.Value = vbChecked Then
                tx = Me.Flex.TextMatrix(Me.Flex.Row, 0) & "|" & _
                     Me.Flex.TextMatrix(Me.Flex.Row, 1) & "|" & _
                     Me.Flex.TextMatrix(Me.Flex.Row, 2)
                If Me.MTBViewerX1.GetCentroid(h, sx, sy) = True Then
                    Me.MTBViewerX1.AddVirtualText sx, sy, tx, "|"
                End If
            End If
        End If
    End If
End Sub

Private Sub Form_Load()
    Me.lblVersionX.Caption = Me.MTBViewerX1.GetVersion
    Me.MTBViewerX1.SetUnlockKey "Put your key kode"
    CargarGrid
    Me.MTBViewerX1.ColorSelectBox = 1
    'Indique la ruta donde tiene alojado su archivo de licencia
    'Me.MTBViewerX1.PathOfLic = "C:\aaaa\bbb\cccc"
    'o indique un código de desbloqueo facilitado por su proveedor
    'Me.MTBViewerX1.SetUnlockKey "Write your unlock code"
End Sub

Private Sub lblRestSelActual_Click()
    Me.MTBViewerX1.RestrictSelInWorkLayer = Not Me.MTBViewerX1.RestrictSelInWorkLayer
    Me.lblRestSelActual.Caption = Me.MTBViewerX1.RestrictSelInWorkLayer
End Sub

Private Sub MTBViewerX1_ChangedParams()
    CargarParametros
End Sub

Private Sub MTBViewerX1_MTBEntitySelected(ByVal DwgName As String, _
            ByVal Handle As String, ByVal EntType As String, _
            ByVal EntLayer As String, ByVal EntColor As Long, _
            ByVal EntLineType As String, ByVal Area As Double, _
            ByVal Length As Double)
  Dim msg As String
  Dim sx As Double
  Dim sy As Double
  Dim i As Integer
    Select Case Comando
        Case "AREA&PERIMETRO"
            msg = "Área: " & Area & vbCr & "Perímetro: " & Length
            MsgBox msg, vbOKOnly + vbInformation, "MTBViewerX"
        Case "ENLAZAR"
            Me.Flex.TextMatrix(Me.Flex.Row, 3) = DwgName
            Me.Flex.TextMatrix(Me.Flex.Row, 4) = Handle
            Me.Flex.TextMatrix(Me.Flex.Row, 5) = EntType
            msg = Me.Flex.TextMatrix(Me.Flex.Row, 0) & "|" & _
                  Me.Flex.TextMatrix(Me.Flex.Row, 1) & "|" & _
                  Me.Flex.TextMatrix(Me.Flex.Row, 2)
            If Me.MTBViewerX1.GetCentroid(Handle, sx, sy) = True Then
                Me.MTBViewerX1.AddVirtualText sx, sy, msg, "|"
            End If
            Comando = ""
        Case "DESENLAZAR"
            For i = 1 To Me.Flex.Rows - 1
                If Me.Flex.TextMatrix(i, 3) = Me.MTBViewerX1.DwgName _
                   And Me.Flex.TextMatrix(i, 4) = Handle Then
                    Me.Flex.Row = i
                    Exit For
                End If
            Next i
            Me.Flex.TextMatrix(Me.Flex.Row, 3) = ""
            Me.Flex.TextMatrix(Me.Flex.Row, 4) = ""
            Me.Flex.TextMatrix(Me.Flex.Row, 5) = ""
            Me.MTBViewerX1.Redraw
            Comando = ""
        Case Else
            msg = "Entidad del tipo: " & EntType & _
                  " con el handle: " & Handle & Chr(13) & _
                  "Capa: " & EntLayer
            MsgBox msg, vbOKOnly + vbInformation, "MTBViewerX"
            For i = 1 To Me.Flex.Rows - 1
                If Me.Flex.TextMatrix(i, 3) = Me.MTBViewerX1.DwgName _
                   And Me.Flex.TextMatrix(i, 4) = Handle Then
                    Me.Flex.Row = i
                    Me.Flex.SetFocus
                    Exit For
                End If
            Next i
            Comando = ""
    End Select
End Sub

 

Descárgate el programa de pruebas y pon el control a prueba. Espero que te de ideas para tus aplicaciones.

 

 


Código de ejemplo (ZIP):

 

Fichero con el código de ejemplo: MTBViewerX.zip - 5.488 KB
(Lo bajarás desde la Web del autor del artículo)

(MD5 checksum: 87B2A88988A16C0A01AC37BD1033B48E)

 


ir al índice principal del Guille