Jump to content

VBA Read file

mien

By mien
in AutoLISP, Visual LISP & DCL

 Share

Recommended Posts

mien Contributor

mien

Posted
Posted

can someone help me with this code. this code stop at read file...it think it was a logic error, but i cant solve it...thanks..

Public Sub Plot_Click()
Me.Hide
Dim strFileName As String
Dim myFile As Integer
Dim strTextLine As String
Dim arrText As Variant
Dim dblX As Variant
Dim dblY As Variant
Dim dblZ As Variant

strFileName = mstrinpfile
   
   If Dir(strFileName) = "" Then
   Call MsgBox(strFileName & " not found", vbExclamation, "Import XYZ Coordinates")
   
   End If
   
'add parameter
ThisDrawing.SendCommand "PDMODE" & vbCr
ThisDrawing.SendCommand "0" & vbCr
ThisDrawing.SendCommand "PDsize" & vbCr
ThisDrawing.SendCommand "0" & vbCr
ThisDrawing.SendCommand "CMDECHO" & vbCr
ThisDrawing.SendCommand "0" & vbCr
ThisDrawing.SendCommand "-Style" & vbCr
ThisDrawing.SendCommand "WMH" & vbCr
ThisDrawing.SendCommand "Romans" & vbCr
ThisDrawing.SendCommand "0" & vbCr
ThisDrawing.SendCommand "0.75" & vbCr
ThisDrawing.SendCommand "15" & vbCr
ThisDrawing.SendCommand "N" & vbCr
ThisDrawing.SendCommand "N" & vbCr
ThisDrawing.SendCommand "N" & vbCr
ThisDrawing.SendCommand "-Units" & vbCr
ThisDrawing.SendCommand "2" & vbCr
ThisDrawing.SendCommand "3" & vbCr
ThisDrawing.SendCommand "2" & vbCr
ThisDrawing.SendCommand "4" & vbCr
ThisDrawing.SendCommand "90" & vbCr
ThisDrawing.SendCommand "Y" & vbCr
ThisDrawing.SendCommand "-Layer" & vbCr
ThisDrawing.SendCommand "Make" & vbCr
ThisDrawing.SendCommand "WMH_PDEPTH" & vbCr
myFile = FreeFile
Open mstrinpfile For Input As #myFile
   Do While Not EOF(myFile)
   Line Input #myFile, strTextLine
   arrText = Split(strTextLine, ",")
   
   dblX = arrText(0)
   dblY = arrText(1)
   dblZ = arrText(2)
    
            
If (Val(dblZ) >= Val(mintlv1)) Then
ThisDrawing.SendCommand "-color" & vbCr
ThisDrawing.SendCommand "BYLAYER" & vbCr
ThisDrawing.SendCommand "point" & vbCr
ThisDrawing.SendCommand dblY & "," & dblX & "," & dblZ & vbCr
ThisDrawing.SendCommand "-Layer" & vbCr
ThisDrawing.SendCommand "Make" & vbCr
ThisDrawing.SendCommand "WMH_BDEPTH" & vbCr
ThisDrawing.SendCommand "" & vbCr
ThisDrawing.SendCommand "-color" & vbCr
ThisDrawing.SendCommand Val(cl1) & vbCr
ThisDrawing.SendCommand "-Text" & vbCr
ThisDrawing.SendCommand "R" & vbCr
ThisDrawing.SendCommand dblY & "," & dblX & "," & dblZ & vbCr
ThisDrawing.SendCommand "2.0" & vbCr
ThisDrawing.SendCommand "90" & vbCr
ThisDrawing.SendCommand Left(dblZ, 2) & vbCr
ThisDrawing.SendCommand "-Layer" & vbCr
ThisDrawing.SendCommand "Make" & vbCr
ThisDrawing.SendCommand "WMH_SDEPTH" & vbCr
ThisDrawing.SendCommand "" & vbCr
ThisDrawing.SendCommand "-Text" & vbCr
ThisDrawing.SendCommand "ML" & vbCr
ThisDrawing.SendCommand dblY & "," & dblX & "," & dblZ & vbCr
ThisDrawing.SendCommand "1.5" & vbCr
ThisDrawing.SendCommand "90" & vbCr
ThisDrawing.SendCommand Right(dblZ, 1) & vbCr
ThisDrawing.SendCommand "zoom" & vbCr
ThisDrawing.SendCommand "extents" & vbCr
ElseIf (Val(dblZ) >= Val(mintlv2)) Then
ThisDrawing.SendCommand "-color" & vbCr
ThisDrawing.SendCommand "BYLAYER" & vbCr
ThisDrawing.SendCommand "point" & vbCr
ThisDrawing.SendCommand dblY & "," & dblX & "," & dblZ & vbCr
ThisDrawing.SendCommand "-Layer" & vbCr
ThisDrawing.SendCommand "Make" & vbCr
ThisDrawing.SendCommand "WMH_BDEPTH" & vbCr
ThisDrawing.SendCommand "" & vbCr
ThisDrawing.SendCommand "-color" & vbCr
ThisDrawing.SendCommand Val(cl1) & vbCr
ThisDrawing.SendCommand "-Text" & vbCr
ThisDrawing.SendCommand "R" & vbCr
ThisDrawing.SendCommand dblY & "," & dblX & "," & dblZ & vbCr
ThisDrawing.SendCommand "2.0" & vbCr
ThisDrawing.SendCommand "90" & vbCr
ThisDrawing.SendCommand Left(dblZ, 2) & vbCr
ThisDrawing.SendCommand "-Layer" & vbCr
ThisDrawing.SendCommand "Make" & vbCr
ThisDrawing.SendCommand "WMH_SDEPTH" & vbCr
ThisDrawing.SendCommand "" & vbCr
ThisDrawing.SendCommand "-Text" & vbCr
ThisDrawing.SendCommand "ML" & vbCr
ThisDrawing.SendCommand dblY & "," & dblX & "," & dblZ & vbCr
ThisDrawing.SendCommand "1.5" & vbCr
ThisDrawing.SendCommand "90" & vbCr
ThisDrawing.SendCommand Right(dblZ, 1) & vbCr
ThisDrawing.SendCommand "zoom" & vbCr
ThisDrawing.SendCommand "extents" & vbCr
Else
MsgBox "Error!!!!! Fail to Plot", 48, "HydroLab"
End
End If
Loop
ThisDrawing.SendCommand "zoom" & vbCr
ThisDrawing.SendCommand "extents" & vbCr
Close #myFile 'close file
MsgBox "Plot Coordinates Completed"
Me.Show
End Sub

CmdrDuh Community Regular

CmdrDuh

Posted
Posted

for starters, I would get rid of all those send commands, as that is probably the problem. Send command doesn't wait for Autocad to finish what its doing before moving on to the next step, so you are probably out of synch

mien Contributor

mien

Posted
  • Author
Posted

i already tried it, but it not working...can you help me with this..

CmdrDuh Community Regular

CmdrDuh

Posted
Posted

start by looking at ThisDrawing.SetVariable

CmdrDuh Community Regular

CmdrDuh

Posted
Posted

the other thing I see wrong is it doesn't look lilke you have declared your file other than here

strFileName = mstrinpfile

mien Contributor

mien

Posted
  • Author
Posted

i already declare it below option explicit..but it seem dont execute the if...elseif control structure,how can i overcome this problem CmdrDuh..thanks...

SEANT Veteran

SEANT

Posted
Posted

This is a method using direct VBA interaction with the drawing database.

 

Warning: The example modifies, and only deals with a part of your process requirements. You will have to modify the routine to your desired specifications.

 

As mentioned by CmdrDuh, investigate ThisDrawing.SetVariable,

 

Get back to us if you have any problems with those modifications.

 

Option Explicit
Const pi As Double = 3.14159265

Sub CommandButton20_Click()
Dim strFileName As String
Dim myFile As Integer
Dim outfile As String
Dim strTextLine As String
Dim arrText As Variant
Dim point As AcadPoint
Dim cllyr As AcadLayer
Dim strName As String
Dim acText As AcadText
Dim dblPt(2) As Double
Dim mintlv1 As Double
Dim mintlv2 As Double
Dim strTemp As String

mintlv1 = -8# 'temp assignment
mintlv2 = -10# 'temp assignment

Set cllyr = ThisDrawing.Layers.Add("WMH_PDEPTH")
cllyr.color = acGreen
Set cllyr = ThisDrawing.Layers.Add("WMH_BDEPTH")
cllyr.color = acBlue
Set cllyr = ThisDrawing.Layers.Add("WMH_SDEPTH")
cllyr.color = acRed
With ThisDrawing.Utility
  strFileName = "C:\Hydro.txt" 'temp assignment
      'On Error GoTo ErrorHandlerPoint
  If Dir(strFileName) = "" Then
     Call MsgBox(strFileName & " not found", vbExclamation, "Import XYZ Coordinates")
     Exit Sub
         'GoTo TidyUpAndExit
  End If
  
  myFile = FreeFile
  Open strFileName For Input As #myFile
  Do While Not EOF(myFile)
      Line Input #myFile, strTextLine
      arrText = Split(strTextLine, ",")
       
      
      dblPt(0) = .DistanceToReal(arrText(0), acDecimal)
      dblPt(1) = .DistanceToReal(arrText(1), acDecimal)
      dblPt(2) = .DistanceToReal(arrText(2), acDecimal)
      
   
      
     Select Case dblPt(2)
        Case Is <= mintlv1 > mintlv2
           Set point = ThisDrawing.ModelSpace.AddPoint(dblPt)
           point.Layer = "WMH_PDEPTH"
           strTemp = Left(arrText(2), 2)
           Set acText = ThisDrawing.ModelSpace.AddText(Left(arrText(2), 2), dblPt, 2#)
           acText.Alignment = acAlignmentRight
           acText.Rotation = pi / 2
           acText.Layer = "WMH_BDEPTH"
           acText.TextAlignmentPoint = dblPt
           acText.Update
           strTemp = Right(arrText(2), 2)
           Set acText = ThisDrawing.ModelSpace.AddText(Right(arrText(2), 2), dblPt, 1.5)
           acText.Alignment = acAlignmentMiddleLeft
           acText.Rotation = pi / 2
           acText.Layer = "WMH_SDEPTH"
           acText.TextAlignmentPoint = dblPt
           acText.Update
        Case Is <= mintlv2

        Case Else
  
     End Select

  Loop
  ZoomExtents
End With
End Sub

mien Contributor

mien

Posted
  • Author
Posted

im tried to classify the layer according to the colour...i make a modification but it not working.

Public Sub Plot_Click()
Me.Hide
Dim strFileName As String
Dim myFile As Integer
Dim strTextLine As String
Dim dblX As Double
Dim dblY As Double
Dim dblZ As Double
Dim arrText As Variant
Dim point As AcadPoint
Dim cllyr As AcadLayer
Dim strName As String
Dim acText As AcadText
Dim dblPt(0 To 2) As Double
Dim strTemp As String
With ThisDrawing.Utility
strFileName = mstrinpfile
   'On Error GoTo ErrorHandlerPoint
   If Dir(strFileName) = "" Then
   Call MsgBox(strFileName & " not found", vbExclamation, "Import XYZ Coordinates")
   'GoTo TidyUpAndExit
   End If
myFile = FreeFile
Open strFileName For Input As #myFile
   Do While Not EOF(myFile)
   Line Input #myFile, strTextLine
   arrText = Split(strTextLine, ",")
   
   dblPt(0) = .DistanceToReal(arrText(0), acDecimal)
   dblPt(1) = .DistanceToReal(arrText(1), acDecimal)
   dblPt(2) = .DistanceToReal(arrText(2), acDecimal)
   
Select Case dblPt(2)
        Case Is <= Val(mintlv1)
           
           Set point = ThisDrawing.ModelSpace.AddPoint(dblPt)
           point.Layer = "WMH_PDEPTH"
           Set cllyr = ThisDrawing.Layers.Add("WMH_PDEPTH")
           cllyr.color = Val(cl1)
           strTemp = Left(arrText(2), 3)
           Set acText = ThisDrawing.ModelSpace.AddText(Left(arrText(2), 3), dblPt, 2)
           acText.Alignment = acAlignmentRight
           acText.Rotation = 2 * pi
           acText.Layer = "WMH_BDEPTH"
           Set cllyr = ThisDrawing.Layers.Add("WMH_BDEPTH")
           cllyr.color = Val(cl1)
           acText.TextAlignmentPoint = dblPt
           acText.Update
           strTemp = Right(arrText(2), 1)
           Set acText = ThisDrawing.ModelSpace.AddText(Right(arrText(2), 1), dblPt, 1.5)
           acText.Alignment = acAlignmentMiddleLeft
           acText.Rotation = 2 * pi
           acText.Layer = "WMH_SDEPTH"
           Set cllyr = ThisDrawing.Layers.Add("WMH_SDEPTH")
           cllyr.color = Val(cl1)
           acText.TextAlignmentPoint = dblPt
           acText.Update
           
        Case Val(mintlv2) To Val(mintlv2a)
           Set point = ThisDrawing.ModelSpace.AddPoint(dblPt)
           point.Layer = "WMH_PDEPTH"
           Set cllyr = ThisDrawing.Layers.Add("WMH_PDEPTH")
           cllyr.color = Val(cl2)
           strTemp = Left(arrText(2), 3)
           Set acText = ThisDrawing.ModelSpace.AddText(Left(arrText(2), 3), dblPt, 2)
           acText.Alignment = acAlignmentRight
           acText.Rotation = 2 * pi
           acText.Layer = "WMH_BDEPTH"
           Set cllyr = ThisDrawing.Layers.Add("WMH_BDEPTH")
           cllyr.color = Val(cl2)
           acText.TextAlignmentPoint = dblPt
           acText.Update
           strTemp = Right(arrText(2), 1)
           Set acText = ThisDrawing.ModelSpace.AddText(Right(arrText(2), 1), dblPt, 1.5)
           acText.Alignment = acAlignmentMiddleLeft
           acText.Rotation = 2 * pi
           acText.Layer = "WMH_SDEPTH"
           Set cllyr = ThisDrawing.Layers.Add("WMH_SDEPTH")
           cllyr.color = Val(cl2)
           acText.TextAlignmentPoint = dblPt
           acText.Update
           
       Case Val(mintlv3) To Val(mintlv3a)
           Set point = ThisDrawing.ModelSpace.AddPoint(dblPt)
           point.Layer = "WMH_PDEPTH"
           Set cllyr = ThisDrawing.Layers.Add("WMH_PDEPTH")
           cllyr.color = Val(cl3)
           strTemp = Left(arrText(2), 3)
           Set acText = ThisDrawing.ModelSpace.AddText(Left(arrText(2), 3), dblPt, 2)
           acText.Alignment = acAlignmentRight
           acText.Rotation = 2 * pi
           acText.Layer = "WMH_BDEPTH"
           Set cllyr = ThisDrawing.Layers.Add("WMH_BDEPTH")
           cllyr.color = Val(cl3)
           acText.TextAlignmentPoint = dblPt
           acText.Update
           strTemp = Right(arrText(2), 1)
           Set acText = ThisDrawing.ModelSpace.AddText(Right(arrText(2), 1), dblPt, 1.5)
           acText.Alignment = acAlignmentMiddleLeft
           acText.Rotation = 2 * pi
           acText.Layer = "WMH_SDEPTH"
           Set cllyr = ThisDrawing.Layers.Add("WMH_SDEPTH")
           cllyr.color = Val(cl3)
           acText.TextAlignmentPoint = dblPt
           acText.Update
        Case Else
           MsgBox "Error!!!!! Plot Fail", 44, "HydroLab"
     End Select
  Loop
   ZoomExtents
   Close #myFile
   MsgBox "Plot Coordinates Completed"
   Me.Show
End With
End Sub

BIGAL Grand Master

BIGAL

Posted
Posted

Mein just a suggestion rather than write lines and lines of code once you have a dwg set up save it as a DWT drawing template then it can be used all the time. We have a number of templates that are used for specific proceedures that have everything in them and then actually copy the drawing out into another working template (civ3d v's Acad)

 

When creating your template I would use a script its much easier to do things like make numerous layers

 

the layer script would be

-Layer

n MHOLE1 C 1 LT dashed

n MHOLE2 C 2 LT dashed2

 

etc its easy to copy and paste and edit also the same for setting text styles etc just remember a script is like a recording of the commands you enter on the keyboard.

 

You can type "setvar" "*" so you can easily cut and paste them into a script knowing which ones can take a little while to learn.

 

some examples

"osmode" snap values

 

units setvars with settings

SETVAR "LUNITS" 2

SETVAR "ANGBASE" 0.0

SETVAR "ANGDIR" 0

SETVAR "LUPREC" 0

SETVAR "AUNITS" 0

SETVAR "AUPREC" 0

 

I read you other code as well I would have thought you could type 1 line in a send.command with all the options rather than repeating with individual VbCr makes copying lines easier.

SEANT Veteran

SEANT

Posted
Posted

Setting up a template is a sensible first step.

 

With regard to the PM and run-time error '-2145386476(80200014), that was due to setting an object to a layer that had yet to be created. Flipping these lines would solve that.

Flip.jpg

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
 Share
Go to topic listing
×
×
  • Create New...