I created the craps dice game as you press play your dice rolls if you roll the winning number or losing number when you first hit play it will tell you. if you dont win or lose on first roll you have the chance to use the roll button in order to keep rolling until you win or lose against the first set of dice rolled
i tried using an if else statement to determine the win count and display to the label although it only displays wins if you win on the first roll as you hit the play button not if you win and it took you multiple rolls clicking the roll button
Imports System.IO
Public Class CrapsGame
' die roll constants
Enum DiceNames
SNAKE_EYES = 2
TREY = 3
CRAPS = 7
LUCKY_SEVEN = 7
YO_LEVEL = 11
BOX_CARS = 12
End Enum
' file name and directory constants
Const FILE_PREFIX As String = "/images/die"
Const FILE_SUFFEX As String = ".png"
' instance variables
Dim myPoint As Integer = 0
Dim randomobject As New Random()
Dim winCount As Integer
Dim lossCount As Integer
' begin new game and determine point
Private Sub PlayButton_Click(sender As Object, e As EventArgs) Handles PlayButton.Click
'intialize variables for new game
myPoint = 0
PointBox.Text = "Point"
OutputLabel.Text = " "
' remove point die images
PointDie1PictureBox.Image = Nothing
PointDie2PictureBox.Image = Nothing
Dim Sum As Integer = RollDice() ' roll dice
'check die roll
Select Case Sum
' win on first roll
Case DiceNames.LUCKY_SEVEN, DiceNames.YO_LEVEL
OutputLabel.Text = "you win!!"
' lose on first roll
Case DiceNames.SNAKE_EYES, DiceNames.TREY, DiceNames.BOX_CARS
OutputLabel.Text = "sorry you lose."
Case Else ' player must match point
myPoint = Sum
PointBox.Text = "Point is " & Sum
OutputLabel.Text = "Roll again!"
PointDie1PictureBox.Image = Die1PictureBox.Image
PointDie2PictureBox.Image = Die2PictureBox.Image
PlayButton.Enabled = False ' disable Play Button
RollButton.Enabled = True ' enable Roll Button
End Select ' sum
If (Sum = myPoint Or Sum = DiceNames.CRAPS) Then
If OutputLabel.Text = "you win!!" Then
winCount = winCount + 1
Else
lossCount = lossCount + 1
End If
Label1.Text = "Win Count - " & winCount.ToString() + Environment.NewLine + "Loss Count - " & lossCount.ToString() + Environment.NewLine
End If
End Sub ' playbutton click
' determine outcome of next roll
Private Sub rollButton_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles RollButton.Click
Dim sum As Integer = RollDice() ' roll dice
' determine outcome of roll
If sum = myPoint Then ' player matches point
OutputLabel.Text = "You win!!!"
RollButton.Enabled = False ' disable Roll Button
PlayButton.Enabled = True ' enable Play Button
ElseIf sum = DiceNames.CRAPS Then ' player loses
OutputLabel.Text = "Sorry, you lose."
RollButton.Enabled = False ' disable Roll Button
PlayButton.Enabled = True ' enable Play Button
End If
End Sub ' rollButton_Click
' generate random die rolls
Function RollDice() As Integer
' roll the dice
Dim die1 As Integer = randomobject.Next(1, 7)
Dim die2 As Integer = randomobject.Next(1, 7)
' display image corresponding to each die
DisplayDie(Die1PictureBox, die1)
DisplayDie(Die2PictureBox, die2)
Return (die1 + die2) ' return sum of dice values
End Function ' RollDice
' display die image
Sub DisplayDie(ByVal die As PictureBox, ByVal face As Integer)
' assign die images to PictureBox
die.Image = Image.FromFile(Directory.GetCurrentDirectory & FILE_PREFIX & face & FILE_SUFFEX)
End Sub ' DisplayDie
End Class
You need to increment your counters (winCount or lossCount) in the rollButton_Click subroutine. Currently the counters are only being updates when the Play button is clicked.
I have been attempting to replace Office OLE in a vb6 application with LibreOffice.
I have had some success, however, I am falling short trying to search for text, then create a cursor based on the text that was found, then insert an image at that cursors point in the document.
I have been able to piece together working code that will allow me to search for text, replace text and insert an image, however, I cannot seem to figure out how to create a cursor that will allow me to insert an image at the pace where the text is that I have found . In the provided example, the [PICTUREPLACEHOLDER] text in the document.
Has anyone ever done this before and do they have any suggestions how I can create a cursor that will allow me to specify where the image will be inserted.
I have included the code for the VB6 test app so you can see the source code to see how its currently working.
Any suggestions would be very much appreciated.
Please Note - this is experimental code - very rough and ready - not final code by a long shot - just trying to figure out how this works with LibreOffice Writer.
To run this, you will need to create an empty vb6 app with a button.
You also need LibreOffice installed.
Many thanks
Rod.
Sub firstOOoProc()
Dim oSM 'Root object for accessing OpenOffice from VB
Dim oDesk, oDoc As Object 'First objects from the API
Dim arg() 'Ignore it for the moment !
'Instanciate OOo : this line is mandatory with VB for OOo API
Set oSM = CreateObject("com.sun.star.ServiceManager")
'Create the first and most important service
Set oDesk = oSM.createInstance("com.sun.star.frame.Desktop")
Dim oProvider As Object
Set oProvider = oSM.createInstance("com.sun.star.graphic.GraphicProvider")
'Open an existing doc (pay attention to the syntax for first argument)
Set oDoc = oDesk.loadComponentFromURL("file:///c:/dev/ooo/testfile.doc", "_blank", 0, arg())
' now - replace some text in the document
Dim Txt
Txt = oDoc.GetText
Dim TextCursor
TextCursor = Txt.CreateTextCursor
' attempt to replace some text
Dim SearchDescriptor
Dim Replace
Replace = oDoc.createReplaceDescriptor
Replace.SearchString = "[TESTDATA1]"
Replace.ReplaceString = "THIS IS A TEST"
oDoc.replaceAll Replace
Dim searchCrtiteria
SearchDescriptor = oDoc.createReplaceDescriptor
' Now - attempt try to replace some text with an image
SearchDescriptor.setSearchString ("[PICTUREPLACEHOLDER]")
SearchDescriptor.SearchRegularExpression = False
Dim Found
Found = oDoc.findFirst(SearchDescriptor)
' create cursor to know where to insert the image
Dim oCurs As Object
Set thing = oDoc.GetCurrentController
Set oCurs = thing.GetViewCursor
' make hte call to insert an image from a file into the document
InsertImage oDoc, oCurs, "file:///c:/dev/ooo/imagefilename.jpg", oProvider
'Save the doc
Call oDoc.storeToURL("file:///c:/dev/ooo/test2.sxw", arg())
'Close the doc
oDoc.Close (True)
Set oDoc = Nothing
oDesk.Terminate
Set oDesk = Nothing
Set oSM = Nothing
End Sub
Function createStruct(strTypeName)
Set classSize = objCoreReflection.forName(strTypeName)
Dim aStruct
classSize.CreateObject aStruct
Set createStruct = aStruct
End Function
Sub InsertImage(ByRef oDoc As Object, ByRef oCurs As Object, sURL As String, ByRef oProvider As Object)
' Init variables and instance object
Dim oShape As Object
Dim oGraph As Object
Set oShape = oDoc.createInstance("com.sun.star.drawing.GraphicObjectShape")
Set oGraph = oDoc.createInstance("com.sun.star.text.GraphicObject")
'Set oProvider = serviceManager.CreateInstance("com.sun.star.graphic.GraphicProvider")
' Add shape to document
oDoc.getDrawPage.Add oShape
' Set property path of picture
Dim oProps(0) As Object
Set oProps(0) = MakePropertyValue("URL", sURL)
' Get size from picture to load
Dim oSize100thMM
Dim lHeight As Long
Dim lWidth As Long
Set oSize100thMM = RecommendGraphSize(oProvider.queryGraphicDescriptor(oProps))
If Not oSize100thMM Is Nothing Then
lHeight = oSize100thMM.Height
lWidth = oSize100thMM.Width
End If
' Set size and path property to shape
oShape.graphic = oProvider.queryGraphic(oProps)
' Copy shape in graphic object and set anchor type
oGraph.graphic = oShape.graphic
oGraph.AnchorType = 1 'com.sun.star.Text.TextContentAnchorType.AS_CHARACTER
' Remove shape and resize graphix
Dim oText As Object
Set oText = oCurs.GetText
oText.insertTextContent oCurs, oGraph, False
oDoc.getDrawPage.Remove oShape
If lHeight > 0 And lWidth > 0 Then
Dim oSize
oSize = oGraph.Size
oSize.Height = lHeight * 500
oSize.Width = lWidth * 500
oGraph.Size = oSize
End If
End Sub
'
'Converts a Ms Windows local pathname in URL (RFC 1738)
'Todo : UNC pathnames, more character conversions
'
Public Function ConvertToUrl(strFile) As String
strFile = Replace(strFile, "\", "/")
strFile = Replace(strFile, ":", "|")
strFile = Replace(strFile, " ", "%20")
strFile = "file:///" + strFile
ConvertToUrl = strFile
End Function
'
'Creates a sequence of com.sun.star.beans.PropertyValue s
'
Public Function MakePropertyValue(cName, uValue) As Object
Dim oStruct, oServiceManager As Object
Set oServiceManager = CreateObject("com.sun.star.ServiceManager")
Set oStruct = oServiceManager.Bridge_GetStruct("com.sun.star.beans.PropertyValue")
oStruct.Name = cName
oStruct.Value = uValue
Set MakePropertyValue = oStruct
End Function
'
'A simple shortcut to create a service
'
Public Function CreateUnoService(strServiceName) As Object
Dim oServiceManager As Object
Set oServiceManager = CreateObject("com.sun.star.ServiceManager")
Set CreateUnoService = oServiceManager.createInstance(strServiceName)
End Function
Public Function RecommendGraphSize(oGraph)
Dim oSize
Dim lMaxW As Double
Dim lMaxH As Double
lMaxW = 6.75 * 2540
lMaxH = 9.5 & 2540
If IsNull(oGraph) Or IsEmpty(oGraph) Then
Exit Function
End If
oSize = oGraph.Size100thMM
If oSize.Height = 0 Or oSize.Width = 0 Then
oSize.Height = oGraph.SizePixel.Height * 2540# * Screen.TwipsPerPixelY() '/ 1440
oSize.Width = oGraph.SizePixel.Width * 2540# * Screen.TwipsPerPixelX() '/ 1440
End If
If oSize.Height = 0 Or oSize.Width = 0 Then
Exit Function
End If
If oSize.Width > lMaxW Then
oSize.Height = oSizeHeight * lMax / oSize.Width
oSize.Width = lMaxW
End If
If oSize.Height > lMaxH Then
oSize.Width = oSize.Width * lMaxH / oSize.Height
oSize.Height = lMaxH
End If
RecommendGraphSize = oSize
End Function
Private Sub Command1_Click()
firstOOoProc
End Sub
The content of the testFile.Doc file is as shown below:
This is a test File
[TESTDATA1]
[PICTUREPLACEHOLDER]
It looks like you need to move the view cursor to the found location.
Found = oDoc.findFirst(SearchDescriptor)
oVC = oDoc.getCurrentController().getViewCursor()
oVC.gotoRange(Found, False)
oVC.setString("")
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 have written a module in Excel VBA using MdlTwain but it seems to only be able to scan one page at a time, whereas if I open the Epson Scan Tool it will scan all the pages.
Pressing the button to activate the Macro on the excel sheet brings up this box for the user to select the type of document they are scanning (this is so I can automatically save the file to the correct folder).
After selecting a document a box comes up asking how many pages you are scanning. This is what I am trying to get rid of by having the Automatic Document Feeder scan all the pages at once automatically.
Here is the code for the module.
Sub scanWithMdlTwain()
Application = False
FIF = False
ID = False
CancelClicked = False
Dim Test As Long
Scan.Show
If CancelClicked = True Then Exit Sub
ScanEmpty = True
Do While ScanEmpty = True
ScanEmpty = True
Pages.Show
If CancelClicked = True Then Exit Sub
If ScanEmpty = True Then
MsgBox "You must enter the number of pages you are scanning.", vbOKOnly
End If
Loop
Dim i As Integer
For i = 1 To numOfPages
Test = mdlTwain.TransferWithoutUI(300, BW, 0, 0, 8.5, 11, "Scan" & i & ".jpg")
Next i
End Sub
And for reference, here is the mdlTwain code for TransferWithoutUI (which I didn't write, but I can modify).
Public Function TransferWithoutUI(ByVal sngResolution As Single, _
ByVal tColourType As TWAIN_MDL_COLOURTYPE, _
ByVal sngImageLeft As Single, _
ByVal sngImageTop As Single, _
ByVal sngImageRight As Single, _
ByVal sngImageBottom As Single, _
ByVal sBMPFileName As String) As Long
'----------------------------------------------------------------------------
' Function transfers one image from Twain data source without showing
' the data source user interface (silent transfer).
'
' Input values
' - sngResolution (Single) - resolution of the image in DPI
' (dots per inch)
' - tColourType (UDT) - colour depth of the imaged - monochromatic (BW),
' colours of grey (GREY), full colours (COLOUR)
' - sngImageLeft, sngImageTop, sngImageRight, sngImageBottom (Single) -
' values determine the rectangle on the scanner glass that will
' be scanned (default units are inches) - if you set Right and Bottom
' values to 0, the module sets maximum values the scanner driver allows
' (the bottom right corner of the scanner glass)
' - sBMPFileName (String) - the file name of the saved image
'
' Function returns 0 if OK, 1 if an error occurs
'----------------------------------------------------------------------------
Dim lRtn As Long
Dim lTmp As Long
Dim blTwainOpen As Boolean
Dim lhDIB As Long
On Local Error GoTo ErrPlace
'-------------------------------
' Open Twain Data Source Manager
'-------------------------------
lRtn = OpenTwainDSM()
If lRtn Then GoTo ErrPlace
blTwainOpen = True
'-----------------------
' Open Twain Data Source
'-----------------------
lRtn = OpenTwainDS()
If lRtn Then GoTo ErrPlace
'-----------------------------------------------------------
' Set all important attributes of the image and the transfer
'-----------------------------------------------------------
'----------------------------------------------------------------------
' Set image size and position
' If sngImageRight or sngImageBottom is 0 put physical width and height
' of the scanner into these values
'----------------------------------------------------------------------
If (sngImageRight = 0) Or (sngImageBottom = 0) Then
lRtn = TwainGetOneValue(PHYSICALWIDTH, sngImageRight)
If lRtn Then GoTo ErrPlace
lRtn = TwainGetOneValue(PHYSICALHEIGHT, sngImageBottom)
If lRtn Then GoTo ErrPlace
End If
lRtn = SetImageSize(sngImageLeft, sngImageTop, sngImageRight, sngImageBottom)
If lRtn Then GoTo ErrPlace
'-----------------------------------------------
' Set the image resolution in DPI - both X and Y
'-----------------------------------------------
lRtn = TwainSetOneValue(XRESOLUTION, FIX32, sngResolution)
If lRtn Then GoTo ErrPlace
lRtn = TwainSetOneValue(YRESOLUTION, FIX32, sngResolution)
If lRtn Then GoTo ErrPlace
'--------------------------
' Set the image colour type
'--------------------------
lRtn = TwainSetOneValue(PIXELTYPE, UINT16, tColourType)
If lRtn Then GoTo ErrPlace
'----------------------------------------------------------------
' If the colour type is fullcolour, set the bitdepth of the image
' - 24 bits, 32 bits, ...
'----------------------------------------------------------------
If tColourType = RGB Then lRtn = TwainSetOneValue(BITDEPTH, UINT16, 24)
'---------------------------------------------------
' Set number of images you want to transfer (just 1)
'---------------------------------------------------
lRtn = TwainSetOneValue(XFERCOUNT, INT16, 1)
If lRtn Then GoTo ErrPlace
'----------------------------------------------------
' TRANSFER the image with UI disabled.
' If successful, lhDIB is filled with handle to DIB
'----------------------------------------------------
lRtn = TwainTransfer(False, lhDIB)
If lRtn Then GoTo ErrPlace
'------------------
' Close Data Source
'------------------
lRtn = CloseTwainDS()
If lRtn Then GoTo ErrPlace
'--------------------------
' Close Data Source Manager
'--------------------------
lRtn = CloseTwainDSM()
If lRtn Then GoTo ErrPlace
blTwainOpen = False
'----------------------------------
' Save DIB handle into the BMP file
'----------------------------------
lRtn = SaveDIBToFile(lhDIB, sBMPFileName)
If lRtn Then GoTo ErrPlace
TransferWithoutUI = 0
Exit Function
ErrPlace:
If lhDIB Then lRtn = GlobalFree(lhDIB)
If blTwainOpen Then lRtn = CloseTwainDS(): lRtn = CloseTwainDSM()
TransferWithoutUI = 1
End Function
How can I modify this to scan until the document feeder is empty?
I am very new with Background worker control. I have an existing project that builds file but throughout my project while building files I get the deadlock error.
I am trying to solve it by creating another project that will only consist out of the background worker. I will then merge them.
My problem is I don't know where it will be more effective for my background worker to be implemented and also the main problem is how can I use the SaveDialog with my background worker? I need to send a parameter to my background worker project telling it when my file is being build en when it is done.
This is where my file is being build:
srOutputFile = New System.IO.StreamWriter(strFile, False) 'Create File
For iSeqNo = 0 To iPrintSeqNo
' Loop through al the record types
For Each oRecord As stFileRecord In pFileFormat
If dsFile.Tables.Contains(oRecord.strRecordName) Then
' Loop through al the records
For Each row As DataRow In dsFile.Tables(oRecord.strRecordName).Rows
' Check record id
If oRecord.strRecordId.Length = 0 Then
bMatched = True
Else
bMatched = (CInt(oRecord.strRecordId) = CInt(row.Item(1)))
End If
' Match records
If iSeqNo = CInt(row.Item(0)) And bMatched Then
strRecord = ""
' Loop through al the fields
For iLoop = 0 To UBound(oRecord.stField)
' Format field
If oRecord.stField(iLoop).iFieldLength = -1 Then
If strRecord.Length = 0 Then
strTmp = row.Item(iLoop + 1).ToString
Else
strTmp = strDelimiter & row.Item(iLoop + 1).ToString
End If
ElseIf oRecord.stField(iLoop).eFieldType = enumFieldType.TYPE_VALUE Or _
oRecord.stField(iLoop).eFieldType = enumFieldType.TYPE_AMOUNT_CENT Then
strTmp = row.Item(iLoop + 1).ToString.Replace(".", "").PadLeft(oRecord.stField(iLoop).iFieldLength, "0")
strTmp = strTmp.Substring(strTmp.Length - oRecord.stField(iLoop).iFieldLength)
Else
strTmp = row.Item(iLoop + 1).ToString.PadRight(oRecord.stField(iLoop).iFieldLength, " ").Substring(0, oRecord.stField(iLoop).iFieldLength)
End If
If oRecord.stField(iLoop).iFieldLength > -1 And (bForceDelimiter) And strRecord.Length > 0 Then
strTmp = strDelimiter & strTmp
End If
strRecord = strRecord & strTmp
Next
' Final delimiter
If (bForceDelimiter) Then
strRecord = strRecord & strDelimiter
End If
srOutputFile.WriteLine(strRecord)
End If
Next
End If
Next
Next
You could try this:
Private locker1 As ManualResetEvent = New System.Threading.ManualResetEvent(False)
Private locker2 As ManualResetEvent = New System.Threading.ManualResetEvent(False)
Dim bOpenFileOK As Boolean
Dim myOpenFile As OpenFileDialog = New OpenFileDialog()
Private Sub FileOpener()
While Not bTerminado
If myOpenFile.ShowDialog() = System.Windows.Forms.DialogResult.OK Then
bOpenFileOK = True
Else
bOpenFileOK = False
End If
locker2.Set()
locker1.WaitOne()
End While
End Sub
' Detonator of the action
Private Sub Button1_Click(ByVal sender As System.Object, _
ByVal e As System.EventArgs) Handles Button1.Click
Dim tFileOp As Thread = New Thread(AddressOf FileOpener)
tFileOp.SetApartmentState(ApartmentState.STA)
tFileOp.Start()
' Start BackgroundWorker
BW1.RunWorkerAsync()
End Sub
Private Sub AsyncFunctionForBW(ByVal args As ArrayList)
'[...]
'Change options dinamically for the OpenFileDialog
myOpenFile.Filter = ""
myOpenFile.MultiSelect = True
'Calling the FileDialog
locker1.Set()
locker2.WaitOne()
locker1.Reset()
locker2.Reset()
If bOpenFileOK Then
myStream = myOpenFile.OpenFile()
'[...]
End If
End Sub
It's a little bit complicated but it works.
ManualResetEvents interrupt the execution of code (if they are told to stop) when reached until you use .Set(). If you use .WaitOne() you set it in stop mode, so it will stop again when reached.
This code defines two ManualResetEvents. When you click the Button1 starts the function FileOpener() in a new Thread, and then starts the BackgroundWorker. The FileOpener() function shows a FileOpenDialog and waits in the locker1 so when you use locker1.Set() the function shows the file dialog.
As the myOpenFile is a "global" variable (as well as bOpenFileOK), once the user select the file (or not) you could detect the dialog result (bOpenFileOK) and the selected file.