TheSwamp
Code Red => VB(A) => Topic started by: ML on October 11, 2007, 06:51:08 PM
-
Hi
I am trying to write out my layers from a drawing to a text file.
As far as creating the text file, that part is working fine; it is grabbing the drawing name and creating a text file however
I can not get the layers to write to the file.
My guess is because layers are an object and not a string, even though the layer names are a string..... hummm?????
If I replace the line MyFile.WriteLine ThisDrawing.Layers line with something like MyFile.WriteLine "Hello", it works just fine.
Does anyone know how I can get this to work?
Thank you,
Mark
Sub WriteLayersToATextFile()
Dim FSO, MyFile As Variant
Dim Layr As AcadLayer
Dim Dwgname As String
Set FSO = CreateObject("Scripting.FileSystemObject")
Dwgname = UCase(Left$(ThisDrawing.GetVariable("Dwgname"), Len(ThisDrawing.GetVariable("Dwgname")) - 8))
For Each Layr In ThisDrawing.Layers
Set MyFile = FSO.CreateTextFile("I:\Path\Path\Path\Path\" & Dwgname & ".TXT", True)
MyFile.WriteLine ThisDrawing.Layers
Next Layr
End Sub
-
That's because you're trying to write out to the file the entire layer collection in one hit.
Change this:
MyFile.WriteLine ThisDrawing.Layers
to this:
MyFile.WriteLine Layr.Name
-
Also move your CreateTextFile line OUTSIDE of the for loop - before it in fact, otherwise you will be creating a textfile for each layer in the drawing.
Also don't forget to close the textfile when finished.
-
Dam Glenn
Without even trying it, I know you nailed it!
Of course layer.name DUH
Also, you are correct, if I keep the writetextfile in the loop, I would get a .txt file for each layer
I will move it out
Thank you very much!
Mark
-
Actually,
This may seem like a dumb question but I can do
Set layrs = Thisdrawing.layers
However, if I pull the layr variable out of the loop, then it needs me to set a reference to layr
and I can only use the name method on individual layers
MyFile.WriteLine Layr.Name
So, how would I set a reference to the layr variable so that each layer in the layer collection can be read, then written?
I tried something like this, but no luck
Set layr = Thisdrawing.layers.item (0)
Thanks again,
Mark
-
I don't follow you. Your code posted looks about right, but here is a quick example:
Public Sub SpewLayers()
Dim pLayers As AcadLayers
Dim pLayer As AcadLayer
Set pLayers = ThisDrawing.Layers
For Each pLayer In pLayers
ThisDrawing.Utility.Prompt "Layer name: " & pLayer.Name & vbCrLf
Next
End Sub
-
Hey Glenn
OK, I figured it out and you were partially right.
Absolutely, I had to use the layer.name method to get the layer name
However, the layr.name code must remain in the loop for AutoCAD to grab the name of each layer in the layer collection.
As far as The Writeline method; it will do precisely that; it will write a line for each in layer in the layer collection
Also, as you add layers, you can re run the macro and it will overwrite the existing file with the new layers.
So, here is the working code:
Thank you for the help!
Mark
Sub WriteLayersToATextFile()
Dim FSO, MyFile As Variant
Dim Layr As AcadLayer
Dim Layrs As AcadLayers
Dim Dwgname As String
Set FSO = CreateObject("Scripting.FileSystemObject")
Set Layrs = ThisDrawing.Layers
Dwgname = UCase(Left$(ThisDrawing.GetVariable("Dwgname"), Len(ThisDrawing.GetVariable("Dwgname")) - 4))
Set MyFile = FSO.CreateTextFile("C:\Path\Path\Path\" & Dwgname & ".TXT", True)
For Each Layr In ThisDrawing.Layers
MyFile.WriteLine Layr.Name
Next Layr
MyFile.Close
End Sub
-
Hey Glenn
OK, I figured it out and you were partially right.
Absolutely, I had to use the layer.name method to get the layer name
However, the layr.name code must remain in the loop for AutoCAD to grab the name of each layer in the layer collection.
Mark, I read that Glenn said move the File creation, not the file WriteLine.
.. I can't see where he suggested relocating the MyFile.WriteLine Layr.Name
-
However, the layr.name code must remain in the loop for AutoCAD to grab the name of each layer in the layer collection.
Of course...I never said to remove it from the loop.
-
OK, I figured it out and you were partially right.
No, my answer was exactly right for the question asked.
Kerry, you beat me to it.
-
From your second post:
Also move your CreateTextFile line OUTSIDE of the for loop - before it in fact, otherwise you will be creating a textfile for each layer in the drawing.
Also don't forget to close the textfile when finished.
OK, you're right, you said move the CreateTextFile line outside of the loop.
My fault.
You were right......feel better? :)
Thank you again
Mark
-
I was very tired yesterday.
Sorry guys....
I looked at it last night and it then hit me.
It goes to show that sometimes you do need to walk away from it
Well, anyway, may be someone else will benefit from the final result "posted"
Thank you again
Mark
-
Just a quick note, you might find something helpful here -> http://www.theswamp.org/index.php?topic=1341.15
-
Cool
Thanks M-
Mark
-
Why not add Layer.Color and Layer.Linetype and make it tab delimited, then you can pull it into Excel?
-
Yeah, that is a cool idea CM and I have done something similar in other cases but I guess I never described what I am using it for.
My boss wrote a LISP routine that will grab the layers from the supporting text files (which I am creating with this code)
create a filter in a user's drawing based on those layers, then grab the drawing prefix (dwgprefix) for the project path and use the text file name & ".dwg" to create the nec. AutoCAD (xref) drawing.
We are a very xref friendly company here so this will make it much easier for the user to create the nec. xrefs for their project relativily quickly.
Having said that; I am simply writing some supporting code.
Now, if a person (CAD User) on the floor, or the company overall needs to add a layer(s) for future xrefs, then can just add or delete it from our master dwg xref files, then run this code to regenerate the new text file.
"If someone would like to help me further develop this, I need the layer count minus defpoints and 0 then write that as the first line in the text file, then after that will follow the layernames minus 0 and defpoints.
That would be really cool if someone wants to take my exisiting code and expound on it.
Thank you
Mark
-
Note:
After the filter is created in the drawing, it will obviously be wblocked out but that is all done in The LISP routine, I am just focusing on the text file part
Mark
-
Post your code and I will see what I can add
-
I did CM but here it is again
This will likely require more VBScripting
I appreciate it.
I will also look at it again later if I get time
Thank you very much,
Mark
Sub WriteLayersToATextFile()
Dim FSO, MyFile As Variant
Dim Layr As AcadLayer
Dim Dwgname As String
Set FSO = CreateObject("Scripting.FileSystemObject")
Dwgname = UCase(Left$(ThisDrawing.GetVariable("Dwgname"), Len(ThisDrawing.GetVariable("Dwgname")) - 4))
Set MyFile = FSO.CreateTextFile("C:\Path\Path\Path\" & Dwgname & ".TXT", True)
For Each Layr In ThisDrawing.Layers
MyFile.WriteLine Layr.Name
Next Layr
MyFile.Close
End Sub
-
try this, It puts in the layer cuont at top and bottom. They should match if defpoints exists, or be off by one if not
Option Explicit
Sub WriteLayersToATextFile()
Dim FSO, MyFile As Variant
Dim Layr As AcadLayer
Dim Dwgname As String
Dim intLayerCount As Integer
Set FSO = CreateObject("Scripting.FileSystemObject")
Dwgname = UCase(Left$(ThisDrawing.GetVariable("Dwgname"), Len(ThisDrawing.GetVariable("Dwgname")) - 4))
Set MyFile = FSO.CreateTextFile("C:\" & Dwgname & ".TXT", True)
intLayerCount = ThisDrawing.Layers.Count - 2
MyFile.writeline intLayerCount
intLayerCount = 0
For Each Layr In ThisDrawing.Layers
If Not Layr.Name = "0" Then
If Not Layr.Name = "Defpoints" Then
MyFile.writeline Layr.Name
intLayerCount = intLayerCount + 1
End If
End If
Next Layr
MyFile.writeline intLayerCount
MyFile.Close
End Sub
-
CM
I have not tried the code yet and I am about to
However, I think with the way that VBScript and The Text Stream methods work, I may need to write it
MyFile.writeline intLayerCount & MyFile.writeline Layr.Name
But let's see how it handles it
Thank you for the code
I will try it now
Mark
-
I didn't put any error checking for the layer Defpoints, thats why the layer numbers were there. You could also use the layer number piece to number your layers
Myfile.writeline intlayercount & vbtab and layer.name to number them.
-
Yes that is cool but I can't for this one because The LISP routine reads the top number for the layer count
Then the layers.
-
CM
Thanks again; I really appreciate it
I tweaked it a bit and it seems to be working fine:
I also added in the username method, so it will write the file directly to your desktop if you want to test it
Sub WriteLayersToATextFile2()
Dim FSO, MyFile, Username As Variant
Dim Layr As AcadLayer
Dim Dwgname As String
Dim intLayerCount As Integer
Set FSO = CreateObject("Scripting.FileSystemObject")
Set WshNetwork = CreateObject("WScript.Network")
Username = WshNetwork.Username
Dwgname = UCase(Left$(ThisDrawing.GetVariable("Dwgname"), Len(ThisDrawing.GetVariable("Dwgname")) - 8))
intLayerCount = ThisDrawing.Layers.Count - 2
Set MyFile = FSO.CreateTextFile("C:\Documents and Settings\" & Username & "\Desktop\" & Dwgname & ".TXT", True)
MyFile.writeline intLayerCount
For Each Layr In ThisDrawing.Layers
If Not Layr.Name = "0" Then
If Not Layr.Name = "Defpoints" Then
MyFile.writeline Layr.Name
End If
End If
Next Layr
MyFile.Close
End Sub
I still need to see what will happen if I defpoints does not exist in a drawing
Mark
-
Oh by the way
The code I just posted is dropping 8 characters off the end of the drawing name; I have to try something differet.
You may want to change that back to 4
Mark
-
I took your idea and started writing a Standards Checker that checks fonts, layers, layers for certain blks, etc. I'll post if anybody is interested
-
What idea was that CM?
Of course I would be interested but ACAD has a built in Standards checker (CAD Standards Toolbar)
Mark
-
I couldn't figure out how to get all my standards into the checker, so I started writing my own
Option Explicit
Public Sub GetInfoLayers()
Dim FSO, MyFile As Variant
Dim objLayer As AcadLayer, objFont As AcadTextStyle
Dim strDwgName As String
Dim strLayername As String, strLayerLinetype As String, strLayerColor As String
ThisDrawing.PurgeAll
ThisDrawing.PurgeAll
ThisDrawing.PurgeAll
Set FSO = CreateObject("Scripting.FileSystemObject")
strDwgName = UCase(Left$(ThisDrawing.GetVariable("Dwgname"), Len(ThisDrawing.GetVariable("Dwgname")) - 4))
Set MyFile = FSO.CreateTextFile("C:\" & strDwgName & ".TXT", True)
MyFile.WriteLine "Drawing: " & strDwgName & ", located at: " & ThisDrawing.Path & "\"
CheckLayers:
MyFile.WriteLine " "
MyFile.WriteLine "Non Standard Layers: "
For Each objLayer In ThisDrawing.Layers
strLayername = objLayer.Name
strLayerLinetype = objLayer.Linetype
strLayerColor = objLayer.color
If CheckName(strLayername) = 1 Then
MyFile.WriteLine strLayername & vbTab & strLayerLinetype & vbTab & strLayerColor
End If
Next objLayer
CheckFonts:
MyFile.WriteLine " "
MyFile.WriteLine "Non Standard Fonts:"
For Each objFont In ThisDrawing.TextStyles
Select Case UCase(objFont.fontFile)
Case "ROMANS.SHX"
Case "VERDANA.TTF"
Case Else
MyFile.WriteLine objFont.Name
End Select
Next objFont
CheckTitleBlocks:
CheckImages:
MyFile.WriteLine " "
Dim objRasterImage As AcadRasterImage
' For Each objRasterImage In ThisDrawing.ModelSpace
' If Not objRasterImage.Layer = "ANNO-SCAN" Then
' MyFile.WriteLine "Image: " & objRasterImage.Name & " wrong layer, on layer " & objRasterImage.Layer
' End If
' Next
MyFile.Close
End Sub
Private Function CheckName(LayerName As String) As Integer
Dim FSO, MyLayerFile As Variant
Dim strLayername As String
' Set FSO = CreateObject("Scripting.FileSystemObject")
' 'Set MyLayerFile = FSO.OpenTextFile("c:\layer.txt", ForReading, False, TristateFalse)
Open "c:\layer.txt" For Input As #1 ' txt file is list of good layers to check against
While Not EOF(1)
Line Input #1, strLayername
If LayerName = strLayername Then
Close #1
GoTo Good
End If
Wend
Close #1
CheckName = 1
Exit Function
Good:
CheckName = 0
Exit Function
End Function
This is how far I have gotten so far today, NO ERROR checking, so use at your own risk
-
Im purging 3 times b/c I haven't checked if this method will purge nested entities completly.
Also, the layer checker , I couldn't figure out how to use the FSO object and EOF so I reverted back to VBA Open for Input
-
I also need to add to the font checker to put the text style as well as font file
-
You used The FSO object in the above code
You may not be able to do every ting you want with The File System Object, that is why you need to mix it up :)
Mark
-
CM
Thanks again for your ongoing help!
With the function you supplied;
The macro with now check to see if defpoints exist.
If True
The layer count will be -2
If False
The layer count will be -1
Precisely what I needed.
Below is the code with function
Mark
Sub WriteLayersToText()
Dim FSO, MyFile, Username As Variant
Dim Layr As AcadLayer
Dim Dwgname As String
Dim LayerCount As Integer
Set FSO = CreateObject("Scripting.FileSystemObject")
Set WshNetwork = CreateObject("WScript.Network")
Username = WshNetwork.Username
Dwgname = UCase(Left$(ThisDrawing.GetVariable("Dwgname"), Len(ThisDrawing.GetVariable("Dwgname")) - 4))
If DoesLayerExist("Defpoints") = True Then
LayerCount = ThisDrawing.Layers.Count - 2
Else
LayerCount = ThisDrawing.Layers.Count - 1
End If
Set MyFile = FSO.CreateTextFile("C:\Documents and Settings\" & Username & "\Desktop\" & Dwgname & ".TXT", True)
'MsgBox LayerCount
MyFile.writeline LayerCount
For Each Layr In ThisDrawing.Layers
If Not Layr.Name = "0" Then
If Not Layr.Name = "Defpoints" Then
MyFile.writeline Layr.Name
End If
End If
Next Layr
MyFile.Close
End Sub
Private Function DoesLayerExist(ByRef Layername As String) As Boolean
Dim Layer As AcadLayer
For Each Layer In ThisDrawing.Layers
If UCase(Layer.Name) = UCase(Layername) Then
DoesLayerExist = True
Exit Function
End If
Next Layer
DoesLayerExist = False
End Function