How to split captured stereo sound from mic into two mono wav - directsound

I need help.. I have problem with splitting left & right channel from captured stream from mic (or sound card)
Below code corectly record sound from mic and saving into the wav file
pairs left channel, right channel, left...
How recognize (split) in CapturedData left and right channel ??
[method CreateCaptureBuffer()]
For InPos = 1 To 24000 - 1 Step 2
buffLeft(OutPos) = CaptureData(InPos)
OutPos += 1
Next InPos
I'm tired of unsuccessful attempts...
Regards,
Schift
Imports Microsoft.DirectX
Imports Microsoft.DirectX.DirectSound
Imports System.Threading
Imports System.IO
Public Class Form1
Public PositionNotify As BufferPositionNotify() = New Microsoft.DirectX.DirectSound.BufferPositionNotify(NumberRecordNotifications) {}
Public Const NumberRecordNotifications As Integer = 16
Public NotificationEvent As AutoResetEvent = Nothing
Public applicationBuffer As CaptureBuffer = Nothing
Public CaptureDeviceGuid As Guid = Guid.Empty
Public applicationDevice As Capture = Nothing
Private FileName As String = String.Empty
Private FileName2 As String = String.Empty
Public applicationNotify As Notify = Nothing
Private NotifyThread As Thread = Nothing
Private Wave As FileStream = Nothing
Private Writer As BinaryWriter = Nothing
Private Path As String = String.Empty
Public CaptureBufferSize As Integer = 0
Public NextCaptureOffset As Integer = 0
Private Recording As Boolean = False
Public InputFormat As WaveFormat
Private SampleCount As Integer = 0
Public NotifySize As Integer = 0
Private counter As Integer = 0
Private Capturing As Boolean = False
Private strx As New MemoryStream
Private Sub Form1_Load(ByVal sender As Object, ByVal e As System.EventArgs) Handles Me.Load
Dim captureDevicesCollection As New CaptureDevicesCollection
Console.WriteLine(captureDevicesCollection(2).Description)
CaptureDeviceGuid = captureDevicesCollection(2).DriverGuid
With InputFormat
.AverageBytesPerSecond = 192000
.BitsPerSample = 16
.BlockAlign = 4
.Channels = 2
.FormatTag = WaveFormatTag.Pcm
.SamplesPerSecond = 48000
End With
FileName = "C:\test.wav"
' FileName2 = "C:\testLeft.wav"
Try
applicationDevice = New Capture(CaptureDeviceGuid)
CreateCaptureBuffer()
OnCreateSoundFile()
Catch ex As Exception
Console.WriteLine(ex.Message)
End Try
End Sub
Private Sub CreateCaptureBuffer()
'-----------------------------------------------------------------------------
' Name: CreateCaptureBuffer()
' Desc: Creates a capture buffer and sets the format
'-----------------------------------------------------------------------------
Dim dscheckboxd As New CaptureBufferDescription()
If applicationNotify IsNot Nothing Then
applicationNotify.Dispose()
applicationNotify = Nothing
End If
If applicationBuffer IsNot Nothing Then
applicationBuffer.Dispose()
applicationBuffer = Nothing
End If
If 0 = InputFormat.Channels Then
Return
End If
' Set the notification size
NotifySize = IIf((1024 > InputFormat.AverageBytesPerSecond / 8), 1024, (InputFormat.AverageBytesPerSecond / 8))
NotifySize -= NotifySize Mod InputFormat.BlockAlign
' Set the buffer sizes
CaptureBufferSize = NotifySize * NumberRecordNotifications
' Create the capture buffer
dscheckboxd.BufferBytes = CaptureBufferSize
InputFormat.FormatTag = WaveFormatTag.Pcm
dscheckboxd.Format = InputFormat
' Set the format during creatation
applicationBuffer = New CaptureBuffer(dscheckboxd, applicationDevice)
NextCaptureOffset = 0
InitNotifications()
End Sub
Private Sub InitNotifications()
'-----------------------------------------------------------------------------
' Name: InitNotifications()
' Desc: Inits the notifications on the capture buffer which are handled
' in the notify thread.
'-----------------------------------------------------------------------------
If applicationBuffer Is Nothing Then
Throw New NullReferenceException()
End If
' Create a thread to monitor the notify events
If NotifyThread Is Nothing Then
NotifyThread = New Thread(New ThreadStart(AddressOf WaitThread))
Capturing = True
NotifyThread.Start()
' Create a notification event, for when the sound stops playing
NotificationEvent = New AutoResetEvent(False)
End If
' Setup the notification positions
For i As Integer = 0 To NumberRecordNotifications - 1
PositionNotify(i).Offset = (NotifySize * i) + NotifySize - 1
PositionNotify(i).EventNotifyHandle = NotificationEvent.Handle
Next
applicationNotify = New Notify(applicationBuffer)
' Tell DirectSound when to notify the app. The notification will come in the from
' of signaled events that are handled in the notify thread.
applicationNotify.SetNotificationPositions(PositionNotify, NumberRecordNotifications)
End Sub
Private Sub WaitThread()
While Capturing
'Sit here and wait for a message to arrive
NotificationEvent.WaitOne(Timeout.Infinite, True)
RecordCapturedData()
End While
End Sub
Private Sub RecordCapturedData()
'-----------------------------------------------------------------------------
' Name: RecordCapturedData()
' Desc: Copies data from the capture buffer to the output buffer
'-----------------------------------------------------------------------------
Dim CaptureData As Byte() = Nothing
Dim buffLeft As Byte() = Nothing
Dim buffRight As Byte() = Nothing
Dim ReadPos As Integer
Dim CapturePos As Integer
Dim LockSize As Integer
applicationBuffer.GetCurrentPosition(CapturePos, ReadPos)
LockSize = ReadPos - NextCaptureOffset
If LockSize < 0 Then
LockSize += CaptureBufferSize
End If
' Block align lock size so that we are always write on a boundary
LockSize -= (LockSize Mod NotifySize)
If 0 = LockSize Then
Return
End If
' Read the capture buffer.
CaptureData = DirectCast(applicationBuffer.Read(NextCaptureOffset, GetType(Byte), LockFlag.None, LockSize), Byte())
ReDim buffLeft(24000)
' ReDim buffLeft(UBound(CaptureData))
''ReDim buffRight(UBound(buffLeft))
Dim InPos As Long = 0
Dim OutPos As Long = 0
Dim counter As Long = 0
For InPos = 1 To 24000 - 1 Step 2
buffLeft(OutPos) = CaptureData(InPos)
OutPos += 1
Next InPos
SampleCount += buffLeft.Length - 1
Writer.Write(buffLeft, 0, buffLeft.Length - 1)
' Move the capture offset along
NextCaptureOffset += CaptureData.Length
NextCaptureOffset = NextCaptureOffset Mod CaptureBufferSize
' Circular buffer
End Sub
Private Sub checkboxRecord_CheckedChanged(ByVal sender As Object, ByVal e As System.EventArgs) Handles checkboxRecord.CheckedChanged
Recording = Not Recording
StartOrStopRecord(Recording)
If Not Recording Then
checkboxRecord.Enabled = False
End If
End Sub
Private Sub StartOrStopRecord(ByVal StartRecording As Boolean)
'-----------------------------------------------------------------------------
' Name: StartOrStopRecord()
' Desc: Starts or stops the capture buffer from recording
'-----------------------------------------------------------------------------
If StartRecording Then
' Create a capture buffer, and tell the capture
' buffer to start recording
CreateCaptureBuffer()
applicationBuffer.Start(True)
Else
' Stop the buffer, and read any data that was not
' caught by a notification
applicationBuffer.[Stop]()
RecordCapturedData()
Writer.Seek(4, SeekOrigin.Begin)
' Seek to the length descriptor of the RIFF file.
Writer.Write(CInt(SampleCount + 36))
' Write the file length, minus first 8 bytes of RIFF description.
Writer.Seek(40, SeekOrigin.Begin)
' Seek to the data length descriptor of the RIFF file.
Writer.Write(SampleCount)
' Write the length of the sample data in bytes.
Writer.Close()
' Close the file now.
Writer = Nothing
'<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>
'-------------------------------------
' Set the writer to null.
' Set the FileStream to null.
Wave = Nothing
End If
End Sub
Private Sub CreateRIFF()
'*************************************************************************
'
' Here is where the file will be created. A
' wave file is a RIFF file, which has chunks
' of data that describe what the file contains.
' A wave RIFF file is put together like this:
'
' The 12 byte RIFF chunk is constructed like this:
' Bytes 0 - 3 : 'R' 'I' 'F' 'F'
' Bytes 4 - 7 : Length of file, minus the first 8 bytes of the RIFF description.
' (4 bytes for "WAVE" + 24 bytes for format chunk length +
' 8 bytes for data chunk description + actual sample data size.)
' Bytes 8 - 11: 'W' 'A' 'V' 'E'
'
' The 24 byte FORMAT chunk is constructed like this:
' Bytes 0 - 3 : 'f' 'm' 't' ' '
' Bytes 4 - 7 : The format chunk length. This is always 16.
' Bytes 8 - 9 : File padding. Always 1.
' Bytes 10- 11: Number of channels. Either 1 for mono, or 2 for stereo.
' Bytes 12- 15: Sample rate.
' Bytes 16- 19: Number of bytes per second.
' Bytes 20- 21: Bytes per sample. 1 for 8 bit mono, 2 for 8 bit stereo or
' 16 bit mono, 4 for 16 bit stereo.
' Bytes 22- 23: Number of bits per sample.
'
' The DATA chunk is constructed like this:
' Bytes 0 - 3 : 'd' 'a' 't' 'a'
' Bytes 4 - 7 : Length of data, in bytes.
' Bytes 8 -...: Actual sample data.
'
' **************************************************************************
' Open up the wave file for writing.
Wave = New FileStream(FileName, FileMode.Create)
' WaveFileLeft = New FileStream(FileName2, FileMode.Create)
Writer = New BinaryWriter(Wave)
' Set up file with RIFF chunk info.
Dim ChunkRiff As Char() = {"R"c, "I"c, "F"c, "F"c}
Dim ChunkType As Char() = {"W"c, "A"c, "V"c, "E"c}
Dim ChunkFmt As Char() = {"f"c, "m"c, "t"c, " "c}
Dim ChunkData As Char() = {"d"c, "a"c, "t"c, "a"c}
Dim shPad As Short = 1
' File padding
Dim nFormatChunkLength As Integer = &H10
' Format chunk length.
Dim nLength As Integer = 0
' File length, minus first 8 bytes of RIFF description. This will be filled in later.
Dim shBytesPerSample As Short = 0
' Bytes per sample.
' Figure out how many bytes there will be per sample.
If 8 = InputFormat.BitsPerSample AndAlso 1 = InputFormat.Channels Then
shBytesPerSample = 1
ElseIf (8 = InputFormat.BitsPerSample AndAlso 2 = InputFormat.Channels) OrElse (16 = InputFormat.BitsPerSample AndAlso 1 = InputFormat.Channels) Then
shBytesPerSample = 2
ElseIf 16 = InputFormat.BitsPerSample AndAlso 2 = InputFormat.Channels Then
shBytesPerSample = 4
End If
' Fill in the riff info for the wave file.
Writer.Write(ChunkRiff)
Writer.Write(nLength)
Writer.Write(ChunkType)
'.AverageBytesPerSecond = 192000
'.BitsPerSample = 16
'.BlockAlign = 4
'.Channels = 2
'.FormatTag = WaveFormatTag.Pcm
'.SamplesPerSecond = 48000
' Fill in the format info for the wave file.
Writer.Write(ChunkFmt)
Writer.Write(nFormatChunkLength)
Writer.Write(shPad)
Writer.Write(InputFormat.Channels) 'channels
Writer.Write(InputFormat.SamplesPerSecond) 'samplepersecond
Writer.Write(InputFormat.AverageBytesPerSecond) 'averagebytespersecond
Writer.Write(shBytesPerSample) 'bytespersample
Writer.Write(InputFormat.BitsPerSample) 'bitspersample
' Now fill in the data chunk.
Writer.Write(ChunkData)
Writer.Write(CInt(0))
' The sample length will be written in later.
'<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>
End Sub
Private Sub OnCreateSoundFile()
'-----------------------------------------------------------------------------
' Name: OnCreateSoundFile()
' Desc: Called when the user requests to save to a sound file
'-----------------------------------------------------------------------------
If Recording Then
' Stop the capture and read any data that
' was not caught by a notification
StartOrStopRecord(False)
Recording = False
End If
' Update the UI controls to show the sound as loading a file
checkboxRecord.Enabled = False
Try
CreateRIFF()
Catch
End Try
' Update the UI controls to show the sound as the file is loaded
labelFilename.Text = FileName
checkboxRecord.Enabled = True
' Remember the path for next time
Path = FileName.Substring(0, FileName.LastIndexOf("\"))
End Sub
End Class

write a directshow filter that splits it into two audio outputs?

Related

How to Parse very Large Excel file (>6 GB) and Parse in VBScript?

I have a very Large Excel file (>6 GB) and I need to Parse it in VBScript.
Function LineCount(sFName As String) As Long
Const Bloc = 32 * 1024& '-- 32K bloc
Dim n As Long
Dim sText As String
Dim LfCount As Long
Dim t As Single: t = Timer '-- simple timing
Open sFName For Input As #1
If LOF(1) = 0 Then Close #1: Exit Function
n = LOF(1) Mod Bloc
If n = 0 Then n = Bloc
LineCount = 1
sText = Input(n, #1)
Do
'-- short code: --------------------------------
'LineCount = LineCount + UBound(Split(sText, vbLf))
'-----------------------------------------------
'-- longer code: ~10% faster -------------------
n = -1
Do
n = InStrB(n + 2, sText, vbLf)
If n Then LineCount = LineCount + 1 Else Exit Do
Loop
'-----------------------------------------------
If EOF(1) Then Exit Do
sText = Input(Bloc, #1)
Loop
Close #1
'-- subtract blank line at the bottom of the file
If Right(sText, 1) = vbLf Then LineCount = LineCount - 1
Debug.Print LineCount, Timer - t
End Function
I need to be able to read very large Excel file and create 1,000,000 line excel files off of it. Any suggestions for fast way to read without running into runtime errors of no memory left?
You'd open the large file for input, reading a line at a time, then open a succession of other files for output, writing 1M lines to each one before opening the next, and so on.
Scaled-down version:
Sub SplitTextFile()
Dim fso As Object, t, n As Long, ln, t2 As Object, outNum As Long
Set fso = CreateObject("scripting.filesystemobject")
'create a dummy text file for testing
Set t = fso.createtextfile("C:\Temp\dummy.txt")
For n = 1 To 1000
t.writeline "This is line " & n
Next n
t.Close
Set t = fso.opentextfile("C:\Temp\dummy.txt")
n = 0
outNum = 0
Do While Not t.atendofstream
If n Mod 100 = 0 Then
If Not t2 Is Nothing Then t2.Close
outNum = outNum + 1
Debug.Print "Writing file # " & outNum
Set t2 = fso.createtextfile("C:\Temp\dummy_" & outNum & ".txt", 2)
End If
t2.writeline t.readline
n = n + 1
Loop
t.Close
t2.Close
End Sub

VBA Object with variable or block variable not set error even when is already set

I am currently trying to set conditions such that when a CSV file is not found in the folder, it will continue to find other CSV files. However I'm facing the "object with variable or block variable not set" error at the 2nd private sub readdatavcap2 even when I've already set Set o_file = fs2.OpenTextFile for both 1st and 2nd sub. I'm confused because for the 1st sub, the error does not occurs at o_file.Close after the else statement while for 2nd sub it occurs. Does anybody knows why?
Private Sub readdatavcap1(filename As String, i As Integer)
Application.ScreenUpdating = False
Dim sl As String
Dim first As Integer
Dim second As Integer
Dim j As Long
Dim fs2 As New Scripting.FileSystemObject
Dim o_file As Scripting.TextStream
j = 2 'variable not defined at fs2
If Dir(filename) <> "" Then
Set fs2 = CreateObject("Scripting.FileSystemObject") 'FileSystemObject also called as FSO, provides an easy object based model to access computer's file system.
'o_file contains filename(csv file link)
Set o_file = fs2.OpenTextFile(filename, 1, TristateFalse) '1=Open a file for reading only. You can't write to this file. TristateFalse means u get ascii file by default
'2=ForWriting, 8= Forappending
'o_file contains filename(text file data)
sl = o_file.readline 'Reads an entire line (up to, but not including, the newline character) from a TextStream file and returns the resulting string.
Do While Left(sl, 1) = "#" 'Left Function is used to extract N number of characters from a string from the left side.
sl = o_file.readline
Loop
Do While o_file.atendofstream <> True 'atendofstream = Read-only property that returns True if the file pointer is at the end of a TextStream file; False if it is not.
sl = o_file.readline
first = InStr(32, sl, ",", 1) - 15 'INSTR function returns the position of the first occurrence of a substring in a string.
second = InStr(first + 2, sl, ",", 1) 'syntax of InStr( [start], string, substring, [compare] )
'start sets string position for each search, string = string being search, substring= string expression searched ,
'eg:InStr(1, "Tech on the Net", "t") Result: 9 'Shows that search is case-sensitive
'compare= optional 1= textcompare
'searching for commas in the file in this case
If second = 0 Then
second = Len(sl) + 1 'len=length of file string
End If
If tddb_vramp = True Then
' write the Voltage Ramp to stress part
If i = 2 Then
ActiveWorkbook.Sheets("Ramp_current").Cells(j, 1) = Mid(sl, 2, first - 2)
End If
ActiveWorkbook.Sheets("Ramp_current").Cells(j, i) = Abs(Mid(sl, first + 2, second - 2 - first)) + 0.000000000000001
Else
'Write the normal current trace
ActiveWorkbook.Sheets("currentPTN_STI").Cells(j, 2 * i - 3) = Mid(sl, 15, first - 14)
' The MID function returns the specified number of characters in a text string, starting from a specified position (
'ie. starting from a specified character number).
'Use this function to extract a sub-string from any part of a text string. Syntax: MID(text_string, start_number, char_numbers).
ActiveWorkbook.Sheets("currentPTN_STI").Cells(j, 2 * i - 2) = Abs(Mid(sl, first + 2, second - 2 - first)) + 0.000000000000001
End If
j = j + 1
Loop
If tddb_vramp = False Then
myarray(i) = j - 1
End If
o_file.Close
Else
o_file.Close
End If
End Sub
Private Sub readdatavcap2(filename As String, i As Integer)
(rest of the code same as readdatavcap1)
.
.
.
o_file.Close
Else
o_file.Close <---error occurs here
End If
End Sub
I worked my way through your code but can't do more than confirm what GSerg already said in his first comment, i.e. you can't close a file that isn't open.
Option Explicit
Sub Main()
Dim SourceFolder As String
Dim Fn As String ' Filoe name
Dim i As Integer
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = -1 Then ' if OK is pressed
SourceFolder = .SelectedItems(1)
End If
End With
If SourceFolder <> "" Then ' a folder was chosen
i = 2
Fn = Dir(SourceFolder & "\*.csv")
Do While Len(Fn) > 0
readdatavcap1 Fn, i
Fn = Dir
Loop
End If
End Sub
Private Sub readdatavcap1(filename As String, i As Integer)
' "filename" is a variable used by VBA
' your use of it may cause unexpected problems.
' to check, select the name and press F1.
Dim sl As String
Dim first As Integer
Dim second As Integer
Dim j As Long
Dim fs2 As New Scripting.FileSystemObject
Dim o_file As Scripting.TextStream
Dim tddb_vramp As Boolean
If Dir(filename) <> "" Then
Application.ScreenUpdating = False
j = 2 'variable not defined at fs2
' FileSystemObject also called as FSO, provides an easy object based model
' to access computer's file system.
Set fs2 = CreateObject("Scripting.FileSystemObject")
' o_file contains filename (csv file link)
' 1=Open a file for reading only. You can't write to this file.
' 2=ForWriting, 8= For appending
' TristateFalse means u get ascii file by default.
Set o_file = fs2.OpenTextFile(filename, 1, TristateFalse)
' o_file contains filename(text file data)
' Reads an entire line (up to, but not including, the newline character)
' from a TextStream file and returns the resulting string.
sl = o_file.readline
Do While Left(sl, 1) = "#"
' Left Function is used to extract N number of characters from a string from the left side.
sl = o_file.readline
Loop
' atendofstream = Read-only property that returns True if the file pointer
' is at the end of a TextStream file; False if it is not.
Do While o_file.atendofstream <> True
sl = o_file.readline
' INSTR function returns the position of the first occurrence of a substring in a string.
' syntax of InStr( [start], string, substring, [compare] )
' start sets string position for each search, string = string being search,
' substring= string expression searched ,
' eg:InStr(1, "Tech on the Net", "t") Result: 9
' Shows that search is case-sensitive
' compare= optional 1= textcompare
' searching for commas in the file in this case
first = InStr(32, sl, ",", 1) - 15 ' what if first is negative?
second = InStr(first + 2, sl, ",", 1)
If second = 0 Then
second = Len(sl) + 1 'len=length of file string
End If
' "ActiveWorkbook" seems not necessary unless you intend to have
' several workbooks, all having a sheet "Ramp_current" open at the
' same time, and none of them being ThisWorkbook.
' But if that's your intention "ActiveWorkbook" will lead to
' disaster sooner rather than later.
If tddb_vramp = True Then
' write the Voltage Ramp to stress part
If i = 2 Then
ActiveWorkbook.Sheets("Ramp_current").Cells(j, 1) = Mid(sl, 2, first - 2)
End If
ActiveWorkbook.Sheets("Ramp_current").Cells(j, i) = Abs(Mid(sl, first + 2, second - 2 - first)) + 0.000000000000001
Else
'Write the normal current trace
ActiveWorkbook.Sheets("currentPTN_STI").Cells(j, 2 * i - 3) = Mid(sl, 15, first - 14)
' The MID function returns the specified number of characters in a text string,
' starting from a specified position (ie. starting from a specified character number).
' Use this function to extract a sub-string from any part of a text string.
' Syntax: MID(text_string, start_number, char_numbers).
ActiveWorkbook.Sheets("currentPTN_STI").Cells(j, 2 * i - 2) = Abs(Mid(sl, first + 2, second - 2 - first)) + 0.000000000000001
End If
j = j + 1
Loop
If tddb_vramp = False Then
myarray(i) = j - 1
End If
o_file.Close
Application.ScreenUpdating = True
Else
' if Dir(filename) = "" The o_file doesn't exist
MsgBox filename & " wasn't found.", _
vbInformation, "Reading failure"
End If
End Sub
You should remove the Else condition from the above code. If you do that the code will do exactly nothing if the file isn't found. This fact would probably induce me to convert this procedure into a function that returns True if the file was found and False if it isn't. Perhaps that's helpful.
The point is that this procedure must be called by a Main proc which loops through all the files in a folder (for example) calling your proc with different file names. So, if your proc returns False the Main might issue a message saying that a file wasn't found. But even if you don't care for that, it's the Main that would select the next file after one has either been found and evaluated or not.

Class not detecting a member which is a Date

I'm trying to build a file to compare the working time for every worker vs their scheduled time.
I've build some classes to achieve that, but I'm having problems when giving times as keys for the dictionary classes.
Here you can see I already have a key #2:30:00# (item 4) and I'm giving a key #2:30:00# but the code wants to add it as a new one:
Once I add it:
Now I have 2 items with the same value (item 4 and item 17).
This is the code for the class:
Option Explicit
Private m_Tramo As Object
Property Get Tramos(ByVal Key As Date) As Tramos
With m_Tramo
If Not .Exists(Key) Then .Add Key, New Tramos
End With
Set Tramos = m_Tramo(Key)
End Property
Private Sub Class_Initialize()
Set m_Tramo = CreateObject("Scripting.Dictionary")
End Sub
Private Sub Class_Terminate()
Set m_Tramo = Nothing
End Sub
Public Property Get Keys() As Variant
Keys = m_Tramo.Keys
End Property
Public Property Get Count() As Long
Count = m_Tramo.Count
End Property
There is more to it, but it doesn't matter here.
Now the code to add the keys for the first time:
Sub CalculaTramosProgramados(arr As Variant, Agentes As Buca, Horario As String, AgenteHoy As Dias)
Dim HoraI As Date
HoraI = Left(Horario, 5)
Dim HoraF As Date
HoraF = Right(Horario, 5)
If HoraF < HoraI Then HoraF = HoraF + 1
Dim TramoInicial As Date
If Minute(HoraI) < 30 Then
TramoInicial = TimeSerial(Hour(HoraI), 0, 0)
Else
TramoInicial = TimeSerial(Hour(HoraI), 30, 0)
End If
'Vamos a rellenar con 30 minutos todos los tramos
Dim i As Long
Dim TramoActual As Date
For i = 0 To Application.RoundUp(DateDiff("n", HoraI, HoraF) / 30, 0) - 1
TramoActual = TramoInicial + TimeSerial(0, 30 * i, 0)
AgenteHoy.Tramos(TramoActual).Programado = 30
Next i
'Primer tramo no completo
If Minute(HoraI) <> 0 Or Minute(HoraI) <> 30 Then
If Minute(HoraI) < 30 Then
AgenteHoy.Tramos(TimeSerial(Hour(HoraI), 0, 0)).Programado = 30 - Minute(HoraI)
Else
AgenteHoy.Tramos(TimeSerial(Hour(HoraI), 30, 0)).Programado = 60 - Minute(HoraI)
End If
End If
'Ășltimo tramo no completo
If Minute(HoraF) <> 0 Or Minute(HoraF) <> 30 Then
If Minute(HoraF) < 30 Then
AgenteHoy.Tramos(TimeSerial(Hour(HoraF), 0, 0)).Programado = Minute(HoraF)
Else
AgenteHoy.Tramos(TimeSerial(Hour(HoraF), 30, 0)).Programado = Abs(30 - Minute(HoraF))
End If
End If
End Sub
The parameters are an array full of data, a initialized instance for the main class(which contains this one), schedule and shortcut reference for the parent class for this one (to clean a bit the code).
This procedure fills everything up allright, but when I come back here, then the code tries to add the new time when it already exists.
Sub CargarReales(arr As Variant, Agentes As Buca)
Dim i As Long
Dim Login As String
Dim Centro As String
Dim Dia As Date, Tramo As Date
Dim CargarTramo As Boolean
Dim AgenteHoy As Dias
For i = 2 To UBound(arr)
Dia = arr(i, 1)
Centro = arr(i, 2)
CargarTramo = compruebaTramo(Dia, Centro)
If Not CargarTramo Then GoTo Siguiente
Login = arr(i, 4)
Tramo = Mid(arr(i, 3), 4, 8)
Set AgenteHoy = Agentes.Logins(Login).Dias(Dia)
AgenteHoy.Tramos(Tramo).Real = arr(i, 5) / 60
Siguiente:
Next i
End Sub
Again, parameters are an array full of data and the main class.
I made sure that everything the code was providing to the class was the right type of variable, in this case Date variables holding only time, not dates.
Any clues on why is VBA doing this?

can not run CommandButton1_Click in excel VBA

I am almost a newbie for Excel VBA.
I am trying to display values of some cells from a worksheet on the UserForm2 and unload the form when user clicks the CommandButton1.
To avoid building a class for my controls, I am starting with a draft UserForm where all the components I will need are placed on it.
I set the positions of the text boxes, fill them in, set the position of the CommandButton1. These are all Ok, all shows up as expected/planned.
when I click the CommandButton1 on form I hear a "Ding" and the "clicked CB1" message - which I expect to see - is not displayed.
What is that I am doing wrong or what is missing?
Option Explicit
Public leftOfForm As Long
Public topOfForm As Long
Public widthOfForm As Long
Public heightOfForm As Long
' ***********************************
Dim numInfoMessages As Long
Dim heightBox As Long
Dim lengthTextbox As Long
Dim lengthCommandButton As Long
Dim numberOfScreenRows As Long
Dim horizantalPadding As Long
Dim verticalPadding As Long
Dim indexLoop As Integer
Dim contr As Control
Dim theFontSize As Integer
Public Sub CommandButton1_Click()
'
' Just to confirm it is ok --- current userform will be unloaded
'
MsgBox "clicked CB1"
End Sub
Public Sub UserForm_initialize()
'
' Save forms current info - not needed in fact
'
theFontSize = 12
leftOfForm = UserForm2.Left
topOfForm = UserForm2.top
widthOfForm = UserForm2.Width
heightOfForm = UserForm2.Height
numInfoMessages = 6
'
' Calculate userform size based on number of lines to be displayed
'
heightBox = 25
lengthTextbox = 500
lengthCommandButton = 90
verticalPadding = 20
horizantalPadding = 15
numberOfScreenRows = (numInfoMessages + 1) * 2 + 1
'
' Resize form according to the results
'
UserForm2.Width = horizantalPadding * 3 + lengthTextbox + 10
UserForm2.Height = verticalPadding * (numberOfScreenRows + 2)
UserForm2.top = 0
UserForm2.Left = 0
'
' Fill in and allocate the text boxes
'
indexLoop = 1
For Each contr In UserForm2.Controls
If TypeName(contr) = "TextBox" Then
contr.top = (indexLoop) * 2 * verticalPadding
contr.Left = horizantalPadding
contr.Width = lengthTextbox
contr.Height = heightBox
contr.BorderStyle = 1
contr.Text = ThisWorkbook.Worksheets(ThisWorkbook.messagesPageName).Range("B" & indexLoop + 1).Value
contr.WordWrap = False
contr.MultiLine = False
contr.Font.Size = theFontSize
indexLoop = 1 + indexLoop
End If
Next
'
' Allocate the command button
'
For Each contr In UserForm2.Controls
If TypeName(contr) = "CommandButton" Then
contr.top = (indexLoop) * 2 * verticalPadding
contr.Width = lengthCommandButton
contr.Height = heightBox
contr.Width = lengthCommandButton
contr.Left = UserForm2.Width / 2 - contr.Width / 2
contr.top = (indexLoop) * 2 * verticalPadding
contr.Font.Size = theFontSize
End If
Next
End Sub

How to divide text file in chunks so that every chunk I can proceed with individual thread

I want to divide one textfile in 5 total chunks. So that I can use one thread on one chunk and so on. i wrote a code in vb.net but if total lines in textfile is multiple of 5 then only my code cover full textfile lines. Please guide me in this.
Private Function breakTextFile(ByVal path As String)
Dim allLines As String() = File.ReadAllLines(path)
Dim sizeOfFile As Integer = allLines.Length
Dim break As Integer = 5, counter As Integer = 0, startline As Integer = 0
Dim index As Integer = sizeOfFile / break
Dim endline As Integer = 0
endline = index
Dim listOfStringArray As New List(Of ArrayList)
Do While (counter <= break)
Dim chunk As New ArrayList
For i = startline To (endline - 1)
Chunk.Add(allLines(i))
Next
listOfStringArray.Add(chunk)
startline = endline
endline = startline + index
counter = counter + 1
Loop
Return listOfStringArray
End Function
Imports MoreLinq
Private Function breakTextFile(ByVal path As String)
Dim listOfStringArray As New List(Of IEnumerable(Of String))
listOfStringArray = File.ReadLines(textFilePath).Batch(10000).ToList()
Return listOfStringArray
End Function

Resources