IntroducciónTras 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.ocxLa 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.
|
