Új hozzászólás Aktív témák

• #2439 új kérdező csendes tag

  Új Válasz 2014-04-20 16:32:20 #2439

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  új kérdező

  csendes tag

  Tisztelt Mindenki!
  Ezúton szeretnék segítséget kérni. autocad 2010-ben írtam egy makrót (VB6) Ami annyit tesz, hogy egy excel táblából átvesz egy cella értéket és megnyitja a hozzá tartozó fájlt és beilleszti a másik oszlopban lévő szöveget blokként, itt jön egy modalis Userform amiben a felhasználó szétrobbantja a beillesztett blokkot. A userformot szerettem volna egy olyannal kiváltani, hogy egy adott billentyűre történjen meg a szétrobbantás de úgy hogy a megnyomás előtt a felhasználó a beillesztett blokkot tudja forgatni meg stb. De mivel ezt nem tudom ezért lett a modális Userform, mivel nagyon- nagyon gyenge vagyok a témában.
  De igazából nem ezt a fő gondom.Erre a feladatra szeretnék egy ciklust kérni, azaz, hogy az exceltáblában menjen végig a sorokon amíg el nem fogynak az adatok, de úgy, hogy várja meg amíg a Userformon lévő művelet is lezajlik.
  Sub Example_StartAngle()
  Dim xlApp As Object
  
  Dim xlBook As Object
  Dim xlBooks As Object
  Dim xlSheets As Object
  Dim xlSheet As Object
  Dim xlCells As Object
  Dim xlRange As Object
  Dim futott As Boolean
  futott = True
  On Error Resume Next
  
  Set xlApp = GetObject(, "Excel.Application")
  If xlApp Is Nothing Then
  futott = False
  
  Set xlApp = CreateObject("Excel.Application")
  
  If xlApp Is Nothing Then
  
  MsgBox "nem sikerült elindítani az exel-et"
  End If
  End If
  ' AutoCAD alkalmazás ablak megjelenítése
  xlApp.Application.Visible = True
  Set xlBooks = xlApp.Workbooks
  If xlBooks.Count > 0 Then
  Set xlBook = xlBooks.Item(1)
  End If
  If xlBooks.Count = 0 Then
  Set xlBook = xlBooks.Open("C:\Users\ko\Documents\számbeíráshoz.xlsx")
  End If
  Set xlSheets = xlBook.worksheets
  Set xlSheet = xlSheets.Item(sheetName) '<--- change a sheet name (might be a sheet number instead)
  xlSheet.Application.Visible = True
  Set xlCells = xlSheet.Cells
  Set xlRange = xlCells.Range("$A1")
  
  Dim AcadApp As AcadApplication
  Dim MyDxf As AcadDocument
  Set AcadApp = GetObject(, "AutoCAD.Application")
  Dim fnev As String
  
  fnev = Cells(s, 1)
  If fnev = "" Then
  xlApp.Workbooks.Close
  xlApp.Quit
  Set xlApp = Nothing
  MsgBox "vége"
  Exit Sub
  End If
  Set MyDxf = AcadApp.Documents.Open("l:\sw2010rajz\dxf-k szöveghez\" & fnev & ".dxf")
  ZoomExtents
  Dim newLayer As AcadLayer
  
  ' Create a Layer and make it the active layer
  Set newLayer = ThisDrawing.Layers.Add("gravir")
  newLayer.Color = acRed
  ThisDrawing.ActiveLayer = newLayer
  ThisDrawing.Regen (True)
  Dim textObj As AcadText
  Dim textString As String
  Dim insertionPoint As Variant
  Dim height As Double
  textString = Cells(s, 2)
  insertionPoint = ThisDrawing.Utility.GetPoint(, "Kattints a beillesztési ponthoz: ")
  height = 5
  Set textObj = ThisDrawing.ModelSpace.AddText(textString, insertionPoint, height)
  ZoomExtents
  Dim exportFile As String
  exportFile = "c:\wmf-k\" & fnev & ""
  
  Dim sset As AcadSelectionSet
  Set sset = ThisDrawing.SelectionSets.Add("NEWSS")
  sset.Select acSelectionSetLast
  'sset.Select acSelectionSetAll
  ' Export the current drawing to the file specified above.
  ThisDrawing.Export exportFile, "WMF", sset
  textObj.Delete
  
  
  Dim blockRefObj As AcadBlockReference
  Dim importFile As String
  Dim InsertPoint As Variant
  Dim scalefactor As Double
  InsertPoint = ThisDrawing.Utility.GetPoint(, "Kattints a beillesztési ponthoz: ")
  
  Set blockRefObj = ThisDrawing.Import("c:\wmf-k\" & fnev & ".wmf", InsertPoint, 2)
  ZoomExtents
  
  
  
  Load UserForm1
  UserForm1.TextBox1.Text = "" & fnev & ""
  
  UserForm1.Show
  
  Kill "c:\wmf-k\" & fnev & ".wmf"
  SaveAs ("l:\sw2010rajz\dxf-k szöveghez\k\" & fnev & ".dxf"), ac2000_dxf
  ThisDrawing.Application.ActiveDocument.Close (True)
  
  xlApp.Workbooks.Close
  xlApp.Quit
  Set xlApp = Nothing
  End Sub
  
  Private Sub CommandButton1_Click()
  
  Dim AcadApp As AcadApplication
  Dim MyDxf As AcadDocument
  Set AcadApp = GetObject(, "AutoCAD.Application")
  UserForm1.Hide
  fnev = TextBox1.Text
  Dim intFilterType(0) As Integer
  Dim varFilterData(0)
  intFilterType(0) = 0
  varFilterData(0) = "Insert"
  Dim explodedObjects As Variant
  Dim I As Integer
  I = 0
  Dim objSSet As AcadSelectionSet
  Dim blkEntry As AcadBlockReference
  Do Until I = 1 'explodes all blocks
  Set objSSet = ThisDrawing.SelectionSets.Add("Block")
  objSSet.Select acSelectionSetAll, , , intFilterType, varFilterData
  For Each blkEntry In objSSet
  explodedObjects = blkEntry.Explode
  Dim C As Integer
  For C = 0 To UBound(explodedObjects)
  explodedObjects(C).Update
  explodedObjects(C).Color = acByLayer
  explodedObjects(C).Lineweight = acLnWtByLayer
  explodedObjects(C).Update
  Next
  blkEntry.Delete
  Next blkEntry
  ThisDrawing.SelectionSets.Item("Block").Delete
  I = I + 1
  Loop
  
  End Sub

  A programban lehet, hogy még vannak felesleges sorok de sebaj. a válaszokat előre is köszönöm.

Új hozzászólás Aktív témák