Both of you thanks a lot! With your information and a lot of other forums I managed to make the script.
I made one to select hatches and set XData to it and one to colour the hatches by the given columnname existing in Excel.
The hatch picker:
Sub PickObject()
Dim i
For i = 0 To 15
'Roep de selectionset op
Dim ssOne As AcadSelectionSet
Set ssOne = SelectOnlyOnScreen
'Kijk of er wel één kavel is geselecteerd
If ssOne.Count = 0 Then
MsgBox "Afsluiten", , "Object"
Exit For
ElseIf ssOne.Count = 1 Then
'Dim de geselecteerde hatch
Dim hatchObject As AcadHatch
Set hatchObject = ssOne.item(0)
'Geef de dim een gekozen naam
Dim plotName As String
plotName = InputBox("Geef de naam van de kavel:", "Kavelnaam", "A1")
Dim xdatatype(0 To 1) As Integer
Dim xdatavalue(0 To 1) As Variant
xdatatype(0) = 1001
xdatatype(1) = 1000
xdatavalue(0) = "Kavel"
xdatavalue(1) = plotName
hatchObject.SetXData xdatatype, xdatavalue
Dim xdatatyperet As Variant
Else
MsgBox "Selecteer één object", , "Object"
i = i - 1
End If
Next i
End Sub
Public Function SelectOnlyOnScreen() As AcadSelectionSet
'Maak de selecionset aan
Dim ssOne As AcadSelectionSet
Dim ssAll As AcadSelectionSets
Set ssAll = ThisDrawing.SelectionSets
For Each ssOne In ssAll
If ssOne.Name = "Plot" Then
'Leeg en verwijder de selectionset
ssOne.Clear
ssOne.Delete
Set ssOne = Nothing
Exit For
End If
Next
Set ssOne = ThisDrawing.SelectionSets.Add("Plot")
'Kies een object voor de selectionset
Dim intType(0) As Integer
Dim varData(0) As Variant
intType(0) = 0 '0 = geen voorwaarden aan het type
varData(0) = "HATCH" 'HATCH = selecteer alleen hatchdata
ssOne.SelectOnScreen intType, varData
Set SelectOnlyOnScreen = ssOne
End Function
The hatch colouring (RGB colours need to be put as text in the Excel next to the desired column):
'Tools -> References -> Microsoft Excel 14.0 Object Library
'Excel moet geopend zijn
'Geef de range van de worksheet op
'Geef het aantal kolommen in de lookup functies
Option Explicit
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim xlRange As Excel.Range
Dim acSpace As AcadModelSpace
Dim totalColumns As Integer
Dim totalRows As Integer
Dim presentColumn As Integer
Function ExcelOpen()
'Deze functie opent Excel
Dim xlObject As Object
Set xlObject = GetObject("D:\School\TU Delft\Master 2\AR2A010 Architectural History Thesis\4 Products\2 Farms\2 Test\Test (3).xlsx")
xlObject.Application.Visible = True
xlObject.Parent.Windows(1).Visible = True
End Function
Function ExcelConnect()
'Deze functie maakt de verbinding tussen AutoCAD en Excel
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
Set xlBook = xlApp.ActiveWorkbook
Set xlSheet = xlBook.Worksheets(1)
xlSheet.Activate
Set xlSheet = xlApp.ActiveSheet
Set xlRange = xlSheet.Range("A1:I17")
If Err Then
Err.Clear
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
If Err Then
MsgBox Err.Description
Exit Function
End If
End If
End Function
Function ExcelClose()
'Deze functie sluit Excel
xlBook.Close False
Set xlBook = Nothing
xlApp.Quit
Set xlApp = Nothing
DoEvents
End Function
Function SetColor(celValue As Variant)
On Error Resume Next
'Maak de selectionset aan
Dim ssOne As AcadSelectionSet
Dim ssAll As AcadSelectionSets
Set ssAll = ThisDrawing.SelectionSets
For Each ssOne In ssAll
If ssOne.Name = "AllEntities" Then 'Als de naam van de selectionset al bestaat
'Leeg en verwijder de selectionset
ssOne.Clear
ssOne.Delete
Set ssOne = Nothing
Exit For
End If
Next
Set ssOne = ThisDrawing.SelectionSets.Add("AllEntities") 'Geef de naam aan de selectionset
'Voeg alle hatches aan de selectionset toe
Dim intGpCode(0) As Integer
Dim varDataValue(0) As Variant
intGpCode(0) = 0 '0 = geen voorwaarden aan de gpcode
varDataValue(0) = "HATCH" 'HATCH = selecteer alleen hatchdatavalues
ssOne.Select acSelectionSetAll, , , intGpCode, varDataValue
'Ga alle hatches in de selectionset af op zoek naar degenen met de juiste naam
Dim ssObject As AcadHatch
Dim varXDataType As Variant
Dim varXDataValue As Variant
Dim msg As String 'Maak een string met alle objecten in de selectionset
msg = vbCrLf 'Start met een enter
Dim color As AcadAcCmColor
Set color = AcadApplication.GetInterfaceObject("AutoCAD.AcCmColor.19") '19 is voor AutoCAD 2013
For Each ssObject In ssOne
'Kijk per kavelnummer in de rijtitel in de Excelsheet of deze hetzelfde is als het kavelnummer van de hatch in AutoCAD
Dim plotType As String
Dim colorValue As String
Dim i As Integer
For i = 1 To totalRows 'Geef het bereik van de rijen op
plotType = celValue(i, 0)
colorValue = celValue(i, presentColumn + 1) 'Leest de cel met rij i en de huidige kolom, "+ 1" om de kleurwaarde te krijgen
Dim colorSplit As Variant
colorSplit = Split(colorValue, ",") 'Splits de cel in drie waarden op (kleur)
ssObject.GetXData "Kavel", varXDataType, varXDataValue
If varXDataValue(1) = plotType Then 'De eerste waarde (0) is "Kavel", de tweede waarde (1) is het kavelnummer
'Geef een kleur aan de hatch
Call color.SetRGB(colorSplit(0), colorSplit(1), colorSplit(2)) 'Gebruikt de drie waarden om een kleur te maken
ssObject.TrueColor = color
ssObject.Evaluate
'MsgBox varXDataValue(1) 'Laat zien welke kavel is ingekleurd
Exit For
End If
Next
msg = msg & vbCrLf & varXDataValue(1) 'Doet een enter en geeft de naam van het object
'Hergenereer het actieve scherm
ThisDrawing.Regen acActiveViewport
Next ssObject
'MsgBox "De selectionset bevat: " & msg 'Laat zien wat er in de selectionset zit
End Function
Private Function LookupColumn(rng As Excel.Range) As Variant
Dim arr()
arr = rng.Value 'De verschillende rijen gesommeerd in een array
ReDim res(1 To totalColumns) 'Geeft het kolombereik van de dim op
'Geef waarden aan het bereik
Dim i
For i = 2 To totalColumns + 1 'Voor de tweede kolom tot de laatste (startwaarde is 1)
res(i - 1) = arr(1, i) 'Onthoudt alle kolomtitels
Next i
'Dim msg As String
'msg = "0" & vbCrLf & "totalColumns"
'MsgBox msg 'Controleer de lengte van de array
LookupColumn = res
End Function
Private Function LookupInRange(rng As Excel.Range, column As Integer) As Variant
Dim arr()
arr = rng.Value 'De verschillende rijen gesommeerd in een array
totalRows = UBound(arr)
ReDim res(0 To totalRows, 0 To totalColumns) 'Geeft het rij- en kolombereik van de dim op
'Geef waarden aan het bereik
Dim i
For i = LBound(arr) + 1 To UBound(arr) 'Voor de eerste rij tot de laatste (startwaarde is 1)
res(i - 1, 0) = arr(i, 1) 'Onthoudt alle rijtitels
res(i - 1, column + 1) = arr(i, column + 2) 'Onthoudt alle kleuren voor de gekozen kolom
Next i
'Dim msg As String
'msg = LBound(arr) & vbCrLf & UBound(arr)
'MsgBox msg 'Controleer de lengte van de array
LookupInRange = res
End Function
Sub ExcelToAcad()
'De Excellink maken
ExcelConnect
'Geef het aantal kolommen
totalColumns = 8 'Deze waarde geven aan de hand van de Excelsheet
'Kies het gewenste type kaart
Dim columnName As Variant
columnName = LookupColumn(xlRange)
Dim mapType As String
mapType = InputBox("Kies het gewenste type kaart:", "Kaarttype", "Oppervlakte")
'Geef de opgegeven kolomnaam door aan de bijbehorende kolom
Dim i As Integer
For i = 1 To totalColumns 'Het bereik van de kolommen
If columnName(i) = mapType Then
mapType = columnName(i)
presentColumn = i
Exit For
End If
Next
'MsgBox columnName(i) 'Kijk of de "columnName" ook de "mapType" is
'Haal de celkleuren die bij de kolom horen op
Dim celValue As Variant
celValue = LookupInRange(xlRange, i)
'MsgBox celValue(1, i + 1) 'Lees een cel (startwaarden zijn 0 (dus rij- en kolomtitels), "+ 1" om de kleurwaarde te krijgen)
'Maak een hatch met de gegeven celdata
SetColor celValue 'Maak de hatch
'Hergenereer het actieve scherm
ThisDrawing.Regen acActiveViewport
End Sub
It's not the most perfect code, but it works. I will spend some more hours to make the code smarter.
