'**********************
'Copyright(C) 2020 Xarial Pty Limited
'Reference: https://www.codestack.net/solidworks-api/document/sheet-metal/export-dxf-dwg/
'License: https://www.codestack.net/license/
'**********************
Enum SheetMetalOptions_e
ExportFlatPatternGeometry = 1
IncludeHiddenEdges = 2
ExportBendLines = 4
IncludeSketches = 8
MergeCoplanarFaces = 16
ExportLibraryFeatures = 32
ExportFormingTools = 64
ExportBoundingBox = 2048
End Enum
Const OUT_PATH As String = "D:\sm.dwg"
Dim swApp As SldWorks.SldWorks
Sub main()
Set swApp = Application.SldWorks
Dim swPart As SldWorks.PartDoc
Set swPart = swApp.ActiveDoc
Dim modelPath As String
modelPath = swPart.GetPathName
If modelPath = "" Then
Err.Raise vbError, "", "Part document must be saved"
End If
If False = swPart.ExportToDWG2(OUT_PATH, modelPath, swExportToDWG_e.swExportToDWG_ExportSheetMetal, True, Empty, False, False, SheetMetalOptions_e.ExportFlatPatternGeometry + SheetMetalOptions_e.ExportBendLines, Empty) Then
Err.Raise vbError, "", "Failed to export flat pattern"
End If
End Sub
solidworks - I want to export a sheet with bend points - unfortunately the above macro does not do it, can someone help me improve it.
The macro exports the plate, but no bend points - where is the error
It was enough to change this line (enter 9) and it started to work
If False = swPart.ExportToDWG2(OUT_PATH, modelPath, swExportToDWG_e.swExportToDWG_ExportSheetMetal, True, Empty, False, False, 9 , Empty) Then
Err.Raise vbError, "", "Failed to export flat pattern"
End If
Related
I want to export my part as dxf as part of a macro. I tried recording it, but when I execute the recording it runs into erroors (see below). Thus I took it to the internet and tried the answer provided to this question
"Macro for Saving Solidworks part configurations as dxf files",
but it doesn't seem to work for me either.
I have tried exporting to other formats, such as step, xt and stl, which all work flawlessly. The macro for dxf export though executes without any errors, but it also does not export/save anything.
Trying to use this with Solidworks2017
I have also tried to record my own macro but it stops at:
Set myView = Part.CreateDrawViewFromModelView3(Part, "*Oben", 0, 0, 0)
with the errormsg:
Runtime error '438': object does not support this property or method.
here the recorded macro in full:
Dim swApp As Object
Dim Part As Object
Dim boolstatus As Boolean
Dim longstatus As Long, longwarnings As Long
Sub main()
Set swApp = Application.SldWorks
Set Part = swApp.ActiveDoc
Dim COSMOSWORKSObj As Object
Dim CWAddinCallBackObj As Object
Set CWAddinCallBackObj = swApp.GetAddInObject("CosmosWorks.CosmosWorks")
Set COSMOSWORKSObj = CWAddinCallBackObj.COSMOSWORKS
Dim FilePath As String
Dim PathSize As Long
Dim PathNoExtention As String
Dim NewFilePath As String
FilePath = Part.GetPathName
PathSize = Strings.Len(FilePath)
PathNoExtention = Strings.Left(FilePath, PathSize - 6)
NewFilePath = PathNoExtention & "dxf"
' Save As
longstatus = Part.SaveAs3(NewFilePath, 0, 0)
' Redraw
Part.GraphicsRedraw2
Set Part = swApp.ActiveDoc
Dim myModelView As Object
Set myModelView = Part.ActiveView
myModelView.FrameLeft = 0
myModelView.FrameTop = 22
Set myModelView = Part.ActiveView
myModelView.FrameState = swWindowState_e.swWindowMaximized
Set Part = swApp.NewDocument("C:\ProgramData\SolidWorks\SOLIDWORKS 2017\templates\Zeichnung.drwdot", 0, 0, 0)
swApp.ActivateDoc2 "Zeichnung5 - Blatt1", False, longstatus
Set Part = swApp.ActiveDoc
Set Part = swApp.ActiveDoc
Set myModelView = Part.ActiveView
myModelView.FrameLeft = 0
myModelView.FrameTop = 0
Set myModelView = Part.ActiveView
myModelView.FrameState = swWindowState_e.swWindowMaximized
swApp.ActivateDoc2 FilePath, False, longstatus
Set Part = swApp.ActiveDoc
Dim myView As Object
Set myView = Part.CreateDrawViewFromModelView3(Part, "*Oben", 0, 0, 0)
Set myView = Part.CreateDrawViewFromModelView3(Part, "*Normal auf", 0, 0, 0)
Part.ClearSelection2 True
Part.ClearSelection2 True
End Sub
Exporting to DXF (or DWG) is different to saving other formats from SolidWorks as you have found out. It's typically used to export flat patterns of sheet metal components.
ExportToDWG2 (IPartDoc) is the API method you need to call to export to either of these two formats. As per the docs it allows you to:
Saves various aspects of a part (sheet metal, faces, loops, and annotation views) to one or more DXF/DWG files'
As such how you use this call will vary based on what you want to export.
Sheet Metal
If you are exporting sheet metal, as per the example you linked, then you will output a flat pattern. However if you try to export sheet metal with a model that does not contain any sheet metal features then the result will be that the call returns false and nothing is output.
The following would be suitable for a sheet metal part:
Dim success As Boolean
success = swPart.ExportToDWG2(dxfFilePath, modelFilePath, swExportToDWG_e.swExportToDWG_ExportSheetMetal, True, Nothing, False, False, sheetMetalOptions, Nothing)
There is no enum in SolidWorks for the sheet metal options but here's one you could use:
Enum SheetMetalOptions_e
None = 0
Geometry = 1
HiddenEdges = 2
BendLines = 4
Sketches = 8
CoplanarFaces = 16
LibraryFeatures = 32
FormingTools = 64
BoundingBox = 2048
End Enum
Usage would be as follows:
' Export geometry, hidden edges and bend lines
Dim sheetMetalOptions As SheetMetalOptions_e
sheetMetalOptions = Geometry Or HiddenEdges Or BendLines
A full macro may look like the below:
Enum SheetMetalOptions_e
None = 0
Geometry = 1
HiddenEdges = 2
BendLines = 4
Sketches = 8
CoplanarFaces = 16
LibraryFeatures = 32
FormingTools = 64
BoundingBox = 2048
End Enum
Sub Main()
' Connect to SolidWorks
Dim swApp As SldWorks.SldWorks
Set swApp = Application.SldWorks
' Connect to the active model
Dim swModel As ModelDoc2
Set swModel = swApp.ActiveDoc
' Validate a model is open
If swModel Is Nothing Then
swApp.SendMsgToUser2 "Open a part to run this macro", swMessageBoxIcon_e.swMbStop, swMessageBoxBtn_e.swMbOk
Exit Sub
End If
' Validate the open model is a part document
If swModel.GetType <> swDocumentTypes_e.swDocPART Then
swApp.SendMsgToUser2 "This macro only runs on part documents", swMessageBoxIcon_e.swMbStop, swMessageBoxBtn_e.swMbOk
Exit Sub
End If
Dim swPart As PartDoc
Set swPart = swModel
' Build the new file path
Dim filePath As String
Dim pathSize As Long
Dim pathNoExtention As String
Dim newFilePath As String
filePath = swModel.GetPathName 'WARNING: this will be an empty string if the part document has not been saved
pathSize = Strings.Len(filePath)
pathNoExtention = Strings.Left(filePath, pathSize - 6) 'WARNING: this assumes the file extension is 6 characters (sldprt)
newFilePath = pathNoExtention & "dxf"
' Define sheet metal information to export
Dim sheetMetalOptions As SheetMetalOptions_e
sheetMetalOptions = Geometry Or HiddenEdges Or BendLines
' Export the DXF
Dim success As Boolean
success = swPart.ExportToDWG2(newFilePath, filePath, swExportToDWG_e.swExportToDWG_ExportSheetMetal, True, Nothing, False, False, 0, Nothing)
' Report success or failure to the user
If success Then
swApp.SendMsgToUser2 "The DXF was exported successfully", swMessageBoxIcon_e.swMbInformation, swMessageBoxBtn_e.swMbOk
Else
swApp.SendMsgToUser2 "Failed to export the DXF", swMessageBoxIcon_e.swMbStop, swMessageBoxBtn_e.swMbOk
End If
End Sub
Faces, Loops or Annotation Views
If your part does not contain sheet metal features then you will have to use one of the alternative export actions: Selected Faces or Loops or Annotation Views.
Annotation Views is supposed to let you pass in an array of view names (such as *Front or *Current) but in my experience it does not work reliably and I am aware that there are some SPRs open against this in SolidWorks.
Selected Faces or Loops requires you to pre-select a face or loop prior to calling ExportToDWG2, so you would have to write some code to determine which faces or loop you want to use and select it, then call ExportToDWG2 with the action parameter set to swExportToDWG_e.swExportToDWG_ExportSelectedFacesOrLoops.
I'm trying to write a macro with VBA in Solidworks that will go through all the sub assemblies and save every part as STEP-file where the name is determined by a custom property. I don't have a lot of programming experience as I'm an mechanical engineer but I try to automate some processes from time to time. Most of this code I got from others and I tried to tweak it to my situation. I do understand most of what is happening though.
The problem I'm having is that I keep getting a
91 runtime error
When I go to debugging Solidworks tells me the problem is in the line name = swPart.GetTitle. At first it said "name = nothing". I tried looking for the problem and when i added Set swApp = Application.SldWorks to the sub I still got the error but now name is always something.
Dim swApp As SldWorks.SldWorks
Dim swAssy As SldWorks.AssemblyDoc
Dim swConf As SldWorks.Configuration
Dim swRootComp As SldWorks.Component2
Dim retVal As Boolean
Dim errors As Long, warnings As Long
Dim revision As String
Dim vaultPath As String
Dim name As String
Dim longstatus As Long, longwarnings As Long
Sub main()
Set swApp = Application.SldWorks
Set swAssy = swApp.ActiveDoc
Set swConf = swAssy.GetActiveConfiguration
Set swRootComp = swConf.GetRootComponent3(True)
vaultPath = "C:\Users\Engineering\Desktop\test\" 'set folder for vault (change this later)
TraverseComponent swRootComp, 1, vaultPath
End Sub
Sub TraverseComponent(swComp As SldWorks.Component2, nLevel As Long, vaultPath As String)
Dim vChilds As Variant, vChild As Variant
Dim swChildComp As SldWorks.Component2
Dim MyString As String
Dim swCustPropMgr As SldWorks.CustomPropertyManager
Set swApp = Application.SldWorks
vChilds = swComp.GetChildren
For Each vChild In vChilds
Set swChildComp = vChild
Dim FileName As String
FileName = swChildComp.GetPathName
FileName = Left(FileName, InStr(FileName, ".") - 1)
FileName = Right(FileName, Len(FileName) - InStrRev(FileName, "\"))
Debug.Print "Part Name : " & FileName
MyString = FileName
Dim ActiveConfig As String
ActiveConfig = swChildComp.ReferencedConfiguration
Debug.Print "Configuration: " & ActiveConfig
FileName = swChildComp.GetPathName
If UCase(Right(FileName, 6)) = "SLDPRT" Then
'MsgBox ("part found")
Dim swPart As SldWorks.ModelDoc2
Set swPart = swApp.OpenDoc6(swChildComp.GetPathName, 1, 0, "", longstatus, longwarnings)
'Dim name As String 'I tried adding this but it made no difference
name = swPart.GetTitle 'get the title of the active document
'chop the extension off if present
If Right(name, 7) = ".SLDPRT" Or Right(name, 7) = ".SLDasm" Then
name = Left(name, Len(name) - 7)
End If
Set swCustPropMgr = swPart.Extension.CustomPropertyManager("") 'get properties
revision = swCustPropMgr.Get("Revision") 'get revision
retVal = swApp.SetUserPreferenceIntegerValue(swUserPreferenceIntegerValue_e.swStepAP, 214) 'change the step file options
'save with revision if present
If revision = "" Or revision = Null Then
retVal = swPart.Extension.SaveAs(vaultPath & name & ".step", swSaveAsVersion_e.swSaveAsCurrentVersion, swSaveAsOptions_e.swSaveAsOptions_Silent, Nothing, errors, warnings)
Else
retVal = swPart.Extension.SaveAs(vaultPath & name & " - Rev " & revision & ".step", swSaveAsVersion_e.swSaveAsCurrentVersion, swSaveAsOptions_e.swSaveAsOptions_Silent, Nothing, errors, warnings)
End If
swApp.CloseDoc swPart.GetTitle
End If
Debug.Print
TraverseComponent swChildComp, nLevel + 1, vaultPath
Next
End Sub
A suppressed component is not the only reason why you could get a "nothing" after calling OpenDoc. This happens e.g. if the component is loaded lightweight or is otherwise not fully loaded. Then you are also not able to get the ModelDoc (PartDoc) data of a component object.
To prevent this completely you could execute the next lines only if the swPart variable is not nothing.
If (Not swPart Is Nothing) Then
name = swPart.GetTitle 'get the title of the active document
...
End If
Additionally I can say you don't necessarily need to use OpenDoc/CloseDoc because the component is already loaded into memory when the assembly is loaded. Therefore it is enough to call GetModelDoc2 of the child component. But in the end it has the same behaviour and will return nothing if the component is not fully loaded.
set swPart = swChildcomp.GetModelDoc2()
Everyone!
I'm working on macros which should select cdrBitmapShape and save it as a separate file.
I've already found out how to search and select such an object, but I've run into a problem of saving it.
I don't get how should I save the chosen image, it is quite unclear from the docs.
As I understand from here I should somehow assign to the Document variable the current selection Item and export it.
Here is the test file
How can I do that?
Sub Findall_bit_map()
' Recorded 03.02.2020
'frmFileConverter.Start
'Dim d As Document
Dim retval As Long
Dim opt As New StructExportOptions
opt.AntiAliasingType = cdrNormalAntiAliasing
opt.ImageType = cdrRGBColorImage
opt.ResolutionX = 600
opt.ResolutionY = 600
Dim pal As New StructPaletteOptions
pal.PaletteType = cdrPaletteOptimized
pal.NumColors = 16
pal.DitherType = cdrDitherNone
Dim Filter As ExportFilter
Set OrigSelection = ActivePage.ActiveLayer.Shapes.All
For Each shpCheck In OrigSelection
re = shpCheck.Type
If shpCheck.Type = cdrBitmapShape Then
retval = MsgBox("BITMAP", vbOKCancel, "Easy Message")
shpCheck.AddToSelection
Set Filter = Document.ExportBitmap("D:\some.jpg", cdrJPEG)
If Filter.ShowDialog() Then
Filter.Finish
Else
MsgBox "Export canceled"
End If
End If
Next shpCheck
retval = MsgBox("Click OK if you agree.", vbOKCancel, "Easy Message")
'ActivePage.Shapes.FindShapes(Query:="#type='BitmapShape'")
If retval = vbOK Then
MsgBox "You clicked OK.", vbOK, "Affirmative"
End If
End Sub
I don't know were was the bug, but here is the working version.
Sub Findall_bit_map_snip()
Dim retval As Long
Dim doc As Document
Dim pal As New StructPaletteOptions
pal.PaletteType = cdrPaletteOptimized
pal.ColorSensitive = True
pal.NumColors = 300000000
pal.DitherType = cdrDitherNone
Dim Filter As ExportFilter
Set OrigSelection = ActivePage.ActiveLayer.Shapes.All
For Each shpCheck In OrigSelection
Set doc = ActiveDocument
doc.ClearSelection
re = shpCheck.Type
If shpCheck.Type = cdrBitmapShape Then
retval = MsgBox("BITMAP", vbOKCancel, "Easy Message")
shpCheck.AddToSelection
Set Filter = doc.ExportBitmap("D:\some.jpg", cdrJPEG, cdrSelection, , , , 600, 600, cdrNoAntiAliasing, , False, , , , pal)
Filter.Finish
End If
Next shpCheck
End Sub
Greetings from Michigan,
I have a program that runs continuously (logging data) where it runs inside a While loop within one Sub ("logging data" Sub), then when the log file becomes "full", it jumps to another Sub to create a new file, then jumps back to the "logging data" Sub to continue on. Anyway, it keeps doing this and can run for hours like this, creating 100+ files or more of data. The problem is that the program crashes at some point and it always crashes within this part of the program (one of these two subs, although I haven't pinpointed which one. When I run the debugger on the machine in which the program is deployed, the Call Stack is rather large. I'm wondering if that is a problem, and how is that managed. Could that be the reason for the program crashing (Call stack getting too large?). I have gotten some sort of memory exception error on at least one of the crashes. I made some edits to the code yesterday to try and alleviate this. This last crash (this morning when I got into the office) that I experienced was a nullreference exception error, although I can't pinpoint where unless I run the program from my development machine in debug mode, which I plan to do next to catch exactly what line of code the crash is happening within either of these two Subs. I'll need to run it overnight as like I said, the program can run for hours before a crash occurs. Anyway, the question is in regards to the Call Stack. Is the large Call Stack a problem? How is that managed/cleared?
Thanks,
D
Public Sub dataAcquiring()
'Receive the collection of channels in this sub and append data to each of the channels
'Set up the channel group
Dim message1 As String = "The data file may have been deleted or moved prior to a new data file and directory being created. Check the main 'Data' directory and be sure the file exists, or simply create a new data file."
Dim testBool As Boolean = False
'Set the global variable to True if running the application from the development machine in debug mode. Otherwise, initialize it to false for deployment.
If Connectlocal = True Then
statsFile = "C:\Users\dmckin01\Desktop\Data\" & folderName & "\" & dataFileName & "_stats.csv"
Else : statsFile = "D:\Data\" & folderName & "\" & dataFileName & "_stats.csv"
End If
Try
logFile.Open()
Catch ex As Exception
MessageBox.Show(Me, ex.Message & message1, "File not found", MessageBoxButtons.OK, MessageBoxIcon.Error)
cbRecord.Checked = False
Return
End Try
Dim i As Integer = 0, n As Integer = 0, hvar As Integer, value As Single, count As Integer = 0, maxValue As Single
Dim b As Boolean = False, returnValue As Type, stringVar As String, lastValidNumber As Integer
Dim dtype As System.Type
Dim channelGroupName As String = "Main Group"
Dim channelGroup As TdmsChannelGroup = New TdmsChannelGroup(channelGroupName)
Dim channelGroups As TdmsChannelGroupCollection = logFile.GetChannelGroups()
If (channelGroups.Contains(channelGroupName)) Then
channelGroup = channelGroups(channelGroupName)
Else
channelGroups.Add(channelGroup)
End If
'Set up the TDMS channels
Dim Names As String() = New String(13) {" Spindle Speed (rpm) ", " Oil Flow (ccm) ", " Torque (Nm) ", " LVDT Displacement (mm) ", " Linear Pot Displacement (mm) ", _
" Pneu. Actuator (0=OFF, 1=ON) ", " Elec. Actuator (0=OFF, 1=ON) ", " Hydr. Actuator (0=OFF, 1=ON) ", _
" Upper Tank Oil Temp. (°F) ", " Lower Tank Oil Temp. (°F) ", " Exit Oil Temp. (°F) ", _
" Inlet Oil Temp. (°F) ", " Part Temp. (°F) ", " Time Stamp "}
Dim dataArrayNames As String() = New String(13) {"arrSpeed", "arrFlow", "arrTorque", "arrLVDT", "arrLinPot", "arrActPneu", "arrActElec", "arrActHydr", _
"arrUpperOil", "arrLowerOil", "arrExitOil", "arrInletOil", "arrTestPart", "arrTimeStamp"}
Dim OPCTagNames As String() = New String(13) {"peakTorque", "peakTorqueSpeed", "peakTorquePlatePos", "timeToPeakTorque", "firstPeakTorque", "firstPeakTorqueSpeed", _
"firstPeakTorquePlatePos", "timeToFirstPeakTorque", "peakDecel", "peakJerk", "engagementSpeed", "slidePlateSpeed", _
"timeOfEngagement", "totalEnergy"}
Dim bools As Boolean() = New Boolean(13) {recSpeed, recOilFlow, recTorque, recLVDT, recLinPot, recActPneu, recActElec, recActHydr, recUpperOil, recLowerOil, _
recExitOil, recInletOil, recTestPart, recTimeStamp}
'Instantiate the TDMS channels to be used. We have to do this each and every time this Sub is executed because National Instruments
'does not have a method to 'clear' the channel group.
Dim ch0 As TdmsChannel = New TdmsChannel(Names(0), TdmsDataType.Float) 'spindle speed
Dim ch1 As TdmsChannel = New TdmsChannel(Names(1), TdmsDataType.Float) 'oil flow
Dim ch2 As TdmsChannel = New TdmsChannel(Names(2), TdmsDataType.Float) 'torque
Dim ch3 As TdmsChannel = New TdmsChannel(Names(3), TdmsDataType.Float) 'actuator position (LVDT)
Dim ch4 As TdmsChannel = New TdmsChannel(Names(4), TdmsDataType.Float) 'actuator position (LINEAR POT)
Dim ch5 As TdmsChannel = New TdmsChannel(Names(5), TdmsDataType.Float) 'actuator state (pneu)
Dim ch6 As TdmsChannel = New TdmsChannel(Names(6), TdmsDataType.Float) 'actuator state (elec)
Dim ch7 As TdmsChannel = New TdmsChannel(Names(7), TdmsDataType.Float) 'actuator state (hydr)
Dim ch8 As TdmsChannel = New TdmsChannel(Names(8), TdmsDataType.Float) 'upper oil tank temp
Dim ch9 As TdmsChannel = New TdmsChannel(Names(9), TdmsDataType.Float) 'lower oil tank temp
Dim ch10 As TdmsChannel = New TdmsChannel(Names(10), TdmsDataType.Float) 'Exit oil tank temp
Dim ch11 As TdmsChannel = New TdmsChannel(Names(11), TdmsDataType.Float) 'Inlet oil temp
Dim ch12 As TdmsChannel = New TdmsChannel(Names(12), TdmsDataType.Float) 'Part temp
Dim ch13 As TdmsChannel = New TdmsChannel(Names(13), TdmsDataType.String) 'Time stamp
Dim Channels As TdmsChannelCollection
Dim chans As TdmsChannel() = New TdmsChannel(13) {ch0, ch1, ch2, ch3, ch4, ch5, ch6, ch7, ch8, ch9, ch10, ch11, ch12, ch13}
Channels = channelGroup.GetChannels()
ch0.UnitString = "RPM" : ch0.Description = "Rotational speed of the spindle shaft."
ch1.UnitString = "CCM" : ch1.Description = "Oil flow from the specimen pump."
ch2.UnitString = "Nm" : ch2.Description = "Torque from the torque cell."
ch3.UnitString = "mm" : ch3.Description = "Linear displacement of the linear velocity displacement transducer."
ch4.UnitString = "mm" : ch4.Description = "Linear displacement of the linear potentiometer."
ch5.UnitString = "BIT" : ch5.Description = "Binary state of the pneumatic actuator (0=OFF, 1=ON)."
ch6.UnitString = "BIT" : ch6.Description = "Binary state of the electric actuator (0=OFF, 1=ON)."
ch7.UnitString = "BIT" : ch7.Description = "Binary state of the hydraulic actuator (0=OFF, 1=ON)."
ch8.UnitString = "°F" : ch8.Description = "Upper tubular tank oil temperature."
ch9.UnitString = "°F" : ch9.Description = "Lower (main) tank oil temperature."
ch10.UnitString = "°F" : ch10.Description = "Thermocouple (Location: Remote rack, EL3318, Ch.2)."
ch11.UnitString = "°F" : ch11.Description = "Thermocouple (Location: Remote rack, EL3318, Ch.3)."
ch12.UnitString = "°F" : ch12.Description = "Thermocouple (Location: Remote rack, EL3318, Ch.1)"
ch13.UnitString = "nS" : ch13.Description = "Time when the data was captured."
'The only TDMS channels that get added to the collection are the ones that the user selects on the 'Configure Data File' form.
'That is what this If-Then block is for.
If Channels.Count = 0 Then
jArray.Clear()
plcArrayNames.Clear()
For Each [boolean] In bools
If [boolean] = True Then
Channels.Add(chans(i))
Channels = channelGroup.GetChannels 'new
jArray.Add(jaggedarray(i))
plcArrayNames.Add(dataArrayNames(i))
End If
i += 1
Next
End If
'At this point, we are ready to write data to the TDMS file.
'Establish the line of communication to the PLC so we can read the data arrays.
Dim tcClient As New TwinCAT.Ads.TcAdsClient()
Dim dataStreamRead As TwinCAT.Ads.AdsStream = New AdsStream
Dim binaryReader As System.IO.BinaryReader = New BinaryReader(dataStreamRead)
If Connectlocal = True Then
tcClient.Connect(851) 'local
Else : tcClient.Connect(AMSNetID, 851)
End If
While cbRecord.Checked = True
b = tcClient2.ReadAny(DRHvar, GetType(Boolean)) 'read the handshaking variable from the PLC
If b = False Then
'This For loop reads the appropriate arrays in the PLC and then writes that data to the appropriate arrays here.
'The arrays in here will eventually get written to the TDMS file.
i = 0
n = 0
writingData = True
For Each [string] In dataArrayNames
If dataArrayNames(n) = plcArrayNames(i) Then
hvar = tcClient.CreateVariableHandle("IO_HS.Data." & dataArrayNames(n))
value = 0
returnValue = jArray(i).GetType
If returnValue.Name = "Single[]" Then
dataStreamRead.SetLength(jArray(0).Length * 4)
dataStreamRead.Position = 0
tcClient.Read(hvar, dataStreamRead)
For Each [element] In jArray(0)
jArray(i)(value) = binaryReader.ReadSingle()
value += 1
Next
ElseIf returnValue.Name = "Int64[]" Then
dataStreamRead.SetLength(jArray(0).Length * 8)
dataStreamRead.Position = 0
tcClient.Read(hvar, dataStreamRead)
For Each [element] In jArray(0)
jArray(i)(value) = binaryReader.ReadInt64()
value += 1
Next
ElseIf returnValue.Name = "String[]" Then
dataStreamRead.SetLength(jArray(0).Length * 32)
dataStreamRead.Position = 0
tcClient.Read(hvar, dataStreamRead)
For Each [element] In jArray(0)
stringVar = binaryReader.ReadChars(32)
lastValidNumber = Math.Max(Math.Max(Math.Max(Math.Max(Math.Max(Math.Max(Math.Max(Math.Max(Math.Max(stringVar.LastIndexOf("0"), stringVar.LastIndexOf("1")), stringVar.LastIndexOf("2")), stringVar.LastIndexOf("3")), stringVar.LastIndexOf("4")), stringVar.LastIndexOf("5")), stringVar.LastIndexOf("6")), stringVar.LastIndexOf("7")), stringVar.LastIndexOf("8")), stringVar.LastIndexOf("9"))
If lastValidNumber > 0 Then
jArray(i)(value) = stringVar.Substring(0, lastValidNumber + 1)
Else
jArray(i)(value) = "Invalid Timestamp"
End If
value += 1
Next
End If
tcClient.DeleteVariableHandle(hvar)
i += 1
If i = plcArrayNames.Count Then
Exit For
End If
End If
n += 1
Next
'This For loop appends/writes the data from each array to the actual TDMS file.
i = 0
For Each [array] In jArray
dtype = Channels(i).GetDataType
If dtype.Name = "Int32" Then
Channels(i).AppendData(Of Integer)(jArray(i))
ElseIf dtype.Name = "Single" Then
Channels(i).AppendData(Of Single)(jArray(i))
ElseIf dtype.Name = "Boolean" Then
Channels(i).AppendData(Of Boolean)(jArray(i))
ElseIf dtype.Name = "String" Then
Channels(i).AppendData(Of String)(jArray(i))
End If
i += 1
Next
Try
'Call the DataAnalyzer dll to write stats of the cycle to stats CSV file. Also plot the data of the cycle on the chart on the UI
Invoke(Sub() DataAnalyzer.Analyze(arrSpeed, arrTorque, arrLinPot))
Invoke(Sub() plotData())
Invoke(Sub() DataAnalyzer.WriteData(statsFile, logFile.Path, arrTimeStamp(0), plcData.cyclesCompleted))
Catch ex As Exception
testBool = True
End Try
'Populate the datagridview cells with the data values
dgvStats.Item(1, 0).Value = DataAnalyzer.peakTorque
dgvStats.Item(1, 1).Value = DataAnalyzer.engagementSpeed
dgvStats.Item(1, 2).Value = DataAnalyzer.slidePlateSpeed
dgvStats.Item(1, 3).Value = plcData.bimbaTravSpeed
dgvStats.Item(1, 4).Value = plcData.lastCycleTime
dgvStats.Item(1, 5).Value = plcData.currentCycleTime
dgvStats.Item(1, 6).Value = plcData.meanCycleTime
dgvStats.Item(1, 7).Value = plcData.cyclesPerHr
'NEW CODE to Evalute the elements in the arrTorque array to get the Max value recorded
maxValue = 0
For Each [element] In arrTorque
maxValue = Math.Max(maxValue, element)
Next
If maxValue <= plcData.torqueAlrmSP And plcData.cycleStarted Then
torqueLowCount += 1
Else : torqueLowCount = 0
End If
'Let the PLC know that we received the data and are now ready for the next set (handshaking variable).
tcClient2.WriteAny(DRHvar, True)
End If
'If the data count in the first column of the TDMS file exceeds the number here, then
'close the file and create a new one, then continue to append/write data
If Channels(0).DataCount >= 1020000 Then
For Each channel As TdmsChannel In chans
channel.Dispose() : channel = Nothing
Next
chans = Nothing
channelGroup.Dispose() : channelGroup = Nothing
If tcClient.IsConnected Then
dataStreamRead.Dispose() : dataStreamRead = Nothing
tcClient.Disconnect() : tcClient.Dispose() : tcClient = Nothing
End If
'Jump to the CreateNewFile Sub to create the next TDMS file
CreateNewFile()
End If
End While
If logFile.IsOpen = True Then
logFile.Close()
End If
If tcClient.IsConnected Then
dataStreamRead.Dispose() : dataStreamRead = Nothing
tcClient.Disconnect() : tcClient.Dispose() : tcClient = Nothing
End If
writingData = False
End Sub
Private Sub CreateNewFile()
'Create the new folder where the data file/s will reside
Dim newFilename As String = dataFileName & "_" & fileNum
Dim customFilePropertyNames() As String = {"Date"}
Dim customFilePropertyVals() As String = {""}
Dim newAuthor As String = logFile.Author
Dim newDescription As String = logFile.Description
Dim newTitle As String = logFile.Title
Dim newPath1 As String = "C:\Users\dmckin01\Desktop\Data\" & folderName
Dim newPath2 As String = "D:\Data\" & folderName
fileNum += 1
'Create the TDMS file and save it to the user specified directory
customFilePropertyVals(0) = Date.Today.ToShortDateString()
logFile.Close() 'Close the old logfile after we've gotten values/properties from it
logFile.Dispose() : logFile = Nothing
Try
If Connectlocal = True Then
logFile = New TdmsFile(newPath1 & "\" & newFilename & ".tdms", New TdmsFileOptions())
Else : logFile = New TdmsFile(newPath2 & "\" & newFilename & ".tdms", New TdmsFileOptions())
End If
Catch ex As Exception
MessageBox.Show("Directory not created. Make sure the TDMS file and/or directory that you are referencing are not already currently opened.", "Directory Creation Failed", MessageBoxButtons.OK, MessageBoxIcon.Error)
Exit Sub
End Try
logFile.Author = newAuthor
logFile.Description = newDescription
logFile.Title = newTitle
logFile.AddProperty(customFilePropertyNames(0), TdmsPropertyDataType.String, customFilePropertyVals(0))
logFile.AutoSave = True
dataAcquiring()
End Sub
Stack errors are always caused by loops in your code that call back on themselves. Often caused by property setting handlers that set other properties that, in their turn, try to set the initial property. They can be difficult to pinpoint sometimes.
In your case, you have called the logging function
dataAcquiring()
End Sub
At then end of the file creation routine... this is a SERIOUS bug.
Each time you start a new file you start a new instance of the log loop and the old one remains on the stack... it's just a matter of time till it runs out of room
In this instance... the create routine should just exit..
However, if it were me I would make that code a function that returns true or false. Have it return false if the file could not be created for some reason and handle it gracefully in the main loop.
I currently have my VBA set up to read a text file (using FileSystemObject) and to find certain strings. This all works great. But what I am trying to achieve is for VBA to read through the text and when it finds a certain string (A) and in the next line below it another string (B) it will do something. But only if B is right after A.
Example:
Find in the following text "Bob's House" and in the next line after that "Electricity.
Text 1: - Return False
blablabla *Bob's House* blablabla
blablabla blablabla blablabla
blabla *Electiricity* blablabla
Text 1: - Return True
blablabla *Bob's House* blablabla
blabla *Electiricity* blablabla
This is what I have so far:
Set fsFile = fs.OpenTextFile(FilePath, 1, False)
sLine = fsFile.ReadLine
If VBA.InStr(1, sLine, "Bobs House") > 0 Then
checkpointHeading = True
End If
If VBA.InStr(1, sLine, "Electricity") > 0 Then
checkpointSubheading = True
End If
If checkpointHeading = True And checkpointSubheading = True Then
MsgBox "Found it!"
End If
This returns "Found it" regardless of how many lines there are between Bobs House and Electricity. Which makes sense. But how do I force the second restraint only after the first is found the line before?
Is there something like sLine +1 / .Readline + 1 (and then apply the second if statement inside the first?).
Thanks in advance, R
You are having this trouble because you are not resetting the 'Bob's House' variable on the next line if that line doesn't equal 'Electricity'. So once Bob's House is found it will always be true and it doesn't matter where 'Electricity' comes in.
You can accomplish what you are after one of two ways. Using Booleans like you have and the code in 'Way 1' (which I've bloated out a bit so its easy to follow), or probably a better way where you simply set the current line string variable to a new string variable which holds the previous line at the end of the loop and then check both of these variables next line like in 'Way 2'.
(Note there are a couple of typos in your example which I've retained so the code works with the example).
Sub Way1()
Dim fs As New FileSystemObject, fsfile As Object
Dim sLine As String
Dim checkpointHeading As Boolean, checkpointSubheading As Boolean
'Open file
Set fsfile = fs.OpenTextFile("G:Test.txt", 1, False)
'Loop through
Do While fsfile.AtEndOfStream <> True
sLine = fsfile.ReadLine
If VBA.InStr(1, sLine, "Bob's House") > 0 Then
checkpointHeading = True
Else
'If the line doesn't have Bob's House then check if the line before did
If checkpointHeading Then
'If it did then check for Electricity
If VBA.InStr(1, sLine, "Electiricity") > 0 Then
'If it's found then happy days
checkpointSubheading = True
Else
'If it's not found then reset everything
checkpointHeading = False: checkpointSubheading = False
End If
End If
End If
'Check if we've found it
If checkpointHeading = True And checkpointSubheading = True Then
MsgBox "Found it!"
'You may want to reset here to be safe
checkpointHeading = False: checkpointSubheading = False
End If
Loop
fsfile.Close
Set fsfile = Nothing
Set fs = Nothing
End Sub
The easier and more concise way 2:
Sub Way2()
Dim fs As New FileSystemObject, fsfile As Object
Dim sLine As String, sPrevLine As String
'Open file
Set fsfile = fs.OpenTextFile("G:Test.txt", 1, False)
'Loop through
Do While fsfile.AtEndOfStream <> True
sLine = fsfile.ReadLine
If VBA.Len(sPrevLine) > 0 Then
If VBA.InStr(1, sPrevLine, "Bob's House") > 0 And VBA.InStr(1, sLine, "Electiricity") Then
MsgBox "Found it!"
End If
End If
'Set the current line to the previous line *at the end of the loop*
sPrevLine = sLine
Loop
fsfile.Close
Set fsfile = Nothing
Set fs = Nothing
End Sub
I didn't test it, but this should demonstrate the logic:
Const filepath = "..."
Sub test()
Dim fs
Dim fsFile
Dim found As Boolean
Dim flag As Boolean
Dim sLine As String
Set fs = CreateObject("Scripting.FileSystemObject")
Set fsFile = fs.OpenTextFile(filepath, 1, False)
found = False
flag = False
Do While Not fsFile.AtEndOfStream And Not found
sLine = fsFile.readLine
If flag And InStr(sLine, "Electricity") Then found = True
flag = (InStr(sLine, "Bobs House") > 0)
Loop
If found Then
MsgBox sLine
Else
MsgBox "not found"
End If
End Sub
Edit: Tested.
Something like this:
sLine = fsFile.ReadLine
If isHeading Then
If InStr(1, sLine, "Electricity") > 0 Then
MsgBox "Found It!"
End If
isHeading = False
End If
If InStr(1, sLine, "Bobs House") > 0 Then
isHeading = True
End If