I have this procedure in visual basic that works for years in Visual Studio 2010 (2015) in windows 7 machine, but I change pc and now in Windows 10 Visual Studio 2017 it only works in debug mode. In runtime mode the procedure loop correctly for 2 time and exit with out error (exit code 0 on console).
In this procedure I loop in array of file information, read email in pdf file and send an email:
Private Sub elaboraFile(lDirectoryFile As String)
Dim i As Integer
Dim eMail, Denominazione, totaleFatt As String
For i = 0 To listaFatture.Length - 1
If File.Exists(lDirectoryFile & "\" & listaFatture(i).nomeFile) Then
' create a new PDF reader based on the PDF template document
Dim pdfReader As PdfReader = New PdfReader(lDirectoryFile & "\" & listaFatture(i).nomeFile)
Dim currentText As String
Dim strategy As New SimpleTextExtractionStrategy()
currentText = PdfTextExtractor.GetTextFromPage(pdfReader, 1, strategy)
currentText = Encoding.UTF8.GetString(ASCIIEncoding.Convert(Encoding.Default, Encoding.UTF8, Encoding.Default.GetBytes(currentText)))
Dim inizioEmail As Integer
Dim inizioDenomCompleta As String
inizioEmail = currentText.IndexOf("E-Mail: ")
If inizioEmail < 1 Then
'Errore indirizzo mail non trovato
listBoxErrori.Items.Add("mail non presente: " & listaFatture(i).nomeFile & " - " & listaFatture(i).denomParziale)
Else
inizioDenomCompleta = currentText.IndexOf(listaFatture(i).denomParziale)
eMail = currentText.Substring(inizioEmail + 8, inizioDenomCompleta - inizioEmail - 8 - 1)
If IsValidEmail(eMail) Then
'Estrazione denominazione Ditta
'inizio: valore di denomParziale
'fine: Spettabile
Denominazione = currentText.Substring(inizioDenomCompleta, currentText.IndexOf("Spettabile") - inizioDenomCompleta - 1)
ListBox1.Items.Add(listaFatture(i).nomeFile & " - " & eMail & " - " & Denominazione)
ListBox1.TopIndex = ListBox1.Items.Count - 1
Dim ldataFattura As String
ldataFattura = Strings.Right(listaFatture(i).dataFattura, 2) & "/"
ldataFattura = ldataFattura & listaFatture(i).dataFattura.Substring(4, 2) & "/"
ldataFattura = ldataFattura & Strings.Left(listaFatture(i).dataFattura, 4)
'Mail
Dim testoMail As String
testoMail = "Buongiorno <b>" & Denominazione & "</b>, <br />" & vbCrLf &
" <br />" & vbCrLf &
"Fattura nr <b>" & listaFatture(i).nrFattura & "</b> del <b>" & ldataFattura & "</b> <br />"
If SendMailAIM(eMail, "Invio fattura", testoMail, lDirectoryFile & "\" & listaFatture(i).nomeFile) = False Then
listBoxErrori.Items.Add("Errore invio mail - " & listaFatture(i).nomeFile & " - " & eMail & " - " & Denominazione & " - " & totaleFatt)
listBoxErrori.TopIndex = listBoxErrori.Items.Count - 1
End If
Else
listBoxErrori.Items.Add("mail errata: " & eMail & " nomefile:" & listaFatture(i).nomeFile & " - " & listaFatture(i).denomParziale)
End If
End If
pdfReader.Close()
pdfReader = Nothing
ResponsiveSleep(7000)
Try
File.Delete(lDirectoryFile & "\" & listaFatture(i).nomeFile)
Catch ex As Exception
listBoxErrori.Items.Add("Impossibile cancellare il file " & listaFatture(i).nomeFile)
End Try
ProgressBar1.PerformStep()
Else
listBoxErrori.Items.Add("Fattura non presente - " & listaFatture(i).nomeFile)
ProgressBar1.PerformStep()
End If
Me.Refresh()
Next
MsgBox("Elaborazione Terminata")
End Sub
Related
I want to be able to tell IF a form is the active window.
It seems simply invoking that method produces an error. I guess I could catch that error and run with it, but it's a backwards way of doing it.
Screen.ActiveForm.Name
This needs a form to be active. If I am breaking any rules of stackOverflow please be kind and remind me as I am new to forum.
Screen.parent, screen.activeControl, etc. What if VBA editor is open, as often it is?
Function CStatus(strStatus, ByRef intType As Integer, Optional ByRef erNo, Optional erMsg, Optional strDatum)
'pXname = "CStatus"
'pXStack = Left(pXStack, 500) & ">" & pXname
'Updates and manages the status bar
Dim strPreamble As String, strOut As String, strForm As String, strComment As String, strSQL As String, strPxStack As String, strCErrStack As String
Dim intColor As Double
Dim intPreLen As Integer
'On Error GoTo err_hand
'Color Codes
'12632256 = Lt Grey
'33023 = Orange
'65280 = Green
'16744576 = Steel Grey
'Define "Constants"
intPreLen = 350 'Length of previous message cache
'** Fix missings
If (IsMissing(strDatum) = True) Then strDatum = "[N/A]"
'** Other inits
strWindow = Screen.Parent.Name
strForm = Screen.ActiveForm.Name
'** intDebug ' Minimum Level of to report to status
'bEcho = True 'Whether to echo to status
intColor = errNoColor(intType)
'Error-level idiot explanations
strComment = "0"
If IsMissing(erNo) Then erNo = 0
If (IsNull(erMsg) = False) Then
If IsMissing(erMsg) = False Then strComment = erMsg
End If
strComment = errorTree(erNo)
strPreamble = Left(strPreamble, intPreLen) & "..."
strErrStack = Left(strErrStack, intPreLen) & " > " & pXname & ":" & intType
strCErrStack = strErrStack
reS:
If ((strForm = "finvmain") Or (strForm = "fclips")) Then Screen.ActiveForm.timeStatusUpdated = Now() 'Small field keeps time
If bEcho = True Then
strPxStack = ""
strCErrStack = "" 'Internal error stack
End If
strOut = Now() & " " & intType & " (" & strType & "): " & erNo & " " & strCErrStack & " >> " & strComment & " / " & strStatus & " [" & strDatum & "] .. " & strPreamble
If bEcho = True Then
If (strForm = "fInvMain") Then Screen.ActiveForm.txtStatus2 = Screen.ActiveForm.txtStatus 'Added second window to show previous message
Screen.ActiveForm.txtStatus = strOut
End If
Screen.ActiveForm.txtStatus.ForeColor = intColor
If strForm = "fInvMain" Then strTag = Screen.ActiveForm.Controls("txttag").value
'***Event Log
If erNo = "" Then erNo = 0
If IsMissing(erMsg) = True Then erMsg = ""
If IsMissing(strDatum) = True Then strDatum = ""
If Len(strPreamble) < 2 Then strPreamble = "[None]"
'Fixxed - Syntax Error for Some Odd Reason! Apr 27th
If ((strTag = Empty) And (strForm = "fInvMain")) Then strTag = Screen.ActiveForm.txtTag 'Attempt to add tag# to entry
strStatus = cleanString(strStatus)
strDatum = cleanString(strDatum)
strComment = cleanString(strComment)
strSQL = "INSERT INTO tEvents(txtdate, myerrno, interrno, myerrmsg, interrmsg, txtform, stack, process, Datum, idLink) VALUES ('" & Now() & "','" & intType & "','" & erNo & "','" & strStatus & "','" & strComment & "','" & strForm & "','" & strErrStack & "','" & pXname & "','" & strDatum & "','" & strTag & "');"
CurrentDb.Execute strSQL, dbFailOnError
Exit Function
err_hand:
If Err.Number = 2475 Then
bEcho = False
Resume reS
Else: MsgBox "555: CStatus Internal Error, Turn off error handling to view"
End If
End Function
I need a boolean true or false IF form is active. If it isn't, I can't put stuff into a textbox in that.
To determine if a particular form is open then set focus to form:
If CurrentProject.AllForms("finvmain").IsLoaded
strForm = "finvmain"
Elseif CurrentProject.AllForms("fclips").IsLoaded Then
strForm = "fclips"
End If
If strForm <> "" Then DoCmd.SelectObject acForm, strForm
I'm using a COM interface to export animations from a third-party program. I'm sending an exporting COM command with script from my tool with a shell command.
There's a problem with when I send the animation export command to the third-party tool. It starts to export, but my tool is sending a second animation export command while the last one is not finished. How can I prevent from this situation?
I'd like to sending my shell command from the for loop after the file was created.
My code is like below.
Private Sub tlbCheckSolveEvaCtrl_exportmodeshape_Click(sender As Object, e As EventArgs) Handles tlbCheckSolveEvaCtrl_exportmodeshape.Click
Try
Dim strArgument As String
Dim strfilePathEV As String
Dim strfilePathANI As String
Dim strfilePathPIC As String
strfilePathEV = strProjMdlDir & My.Settings.txtCheckSolverOuputDir & strProjMdlName & ".ev.sbr"
strfilePathANI = strProjMdlDir & "\" & My.Settings.txtProjDirDOC & "\" & My.Settings.txtProjDirANI & "\"
strfilePathPIC = strProjMdlDir & "\" & My.Settings.txtProjDirDOC & "\" & My.Settings.txtProjDirPIC & "\"
For i As Integer = 0 To dgvCheckSolveEva.RowCount - 1
strArgument = strfilePathEV & " " & _
strfilePathANI & strProjMdlName & "_" & i & ".mpg" & " " & _
i
Shell(My.Settings.txtSpckDir & "simpack-post.exe -s qs_mode_shape.qs " & strArgument)
Next
Catch ex As Exception
MsgBox(ex.Message)
End Try
End Sub
I'd like to continue my for loop if strfilePathANI & strProjMdlName & "_" & i & ".mpg", the animation file was created, so I can start to export the next one.
The best way would be to use the .NET Process class and call the WaitForExit() method in order to wait for simpack-post.exe to close itself.
Shell() is an outdated function from the VB6-era which exists purely for partial backwards compatibility with that language. It shouldn't be used in new code.
Basic example:
Dim filePath As String = Path.Combine(My.Settings.txtSpckDir, "simpack-post.exe")
Process.Start(filePath, "-s qs_mode_shape.qs " & strArgument).WaitForExit()
The problem with this of course is that it might block the UI thread and thus cause it to freeze, depending on how long it takes for the process to exit. Therefore we should wrap it in a Task:
Dim c As Integer = dgvCheckSolveEva.RowCount - 1
Task.Run( _
Sub()
For i As Integer = 0 To c
strArgument = strfilePathEV & " " & _
strfilePathANI & strProjMdlName & "_" & i & ".mpg" & " " & _
i
Dim filePath As String = Path.Combine(My.Settings.txtSpckDir, "simpack-post.exe")
Process.Start(filePath, "-s qs_mode_shape.qs " & strArgument).WaitForExit()
Next
End Sub _
)
Just note that you cannot directly access the UI from within the task. If you want to do so you need to Invoke.
EDIT:
If you are targeting .NET Framework 3.5 or lower, or using VS 2008 or lower, tasks aren't available and we have to resort to using regular threads and/or regular methods instead of lamba expressions.
Note that the same rules apply, though - you cannot access the UI without invoking.
.NET 3.5 (or lower) using VS 2010 (and higher):
Dim c As Integer = dgvCheckSolveEva.RowCount - 1
Dim t As New Thread( _
Sub()
For i As Integer = 0 To c
strArgument = strfilePathEV & " " & _
strfilePathANI & strProjMdlName & "_" & i & ".mpg" & " " & _
i
Dim filePath As String = Path.Combine(My.Settings.txtSpckDir, "simpack-post.exe")
Process.Start(filePath, "-s qs_mode_shape.qs " & strArgument).WaitForExit()
Next
End Sub _
)
t.IsBackground = True
t.Start()
.NET 3.5 (or lower) using VS 2008 (or lower):
Private Sub tlbCheckSolveEvaCtrl_exportmodeshape_Click(sender As Object, e As EventArgs) Handles tlbCheckSolveEvaCtrl_exportmodeshape.Click
...your code...
Dim c As Integer = dgvCheckSolveEva.RowCount - 1
Dim t As New Thread(New ParameterizedThreadStart(AddressOf ExportAnimationsThread))
t.IsBackground = True
t.Start(c)
...your code...
End Sub
Private Sub ExportAnimationsThread(ByVal Count As Integer)
For i As Integer = 0 To Count
strArgument = strfilePathEV & " " & _
strfilePathANI & strProjMdlName & "_" & i & ".mpg" & " " & _
i
Dim filePath As String = Path.Combine(My.Settings.txtSpckDir, "simpack-post.exe")
Process.Start(filePath, "-s qs_mode_shape.qs " & strArgument).WaitForExit()
Next
End Sub
Hi I am creating a chat like application. Can you kindly help me?
When I am entering a new message the initial displayed message is getting replaced :(
Please see my codes below:
Private Sub saveMessage()
FileName = Format(Now, "MMddyyyyhhmmss")
Dim RecipientFile As String
If CurrentRecipient = "Edward" Then
RecipientFile = RecipientFolder & FileName & ".txt"
ElseIf CurrentRecipient = "Criziel" Then
RecipientFile = RecipientFolder & FileName & ".txt"
ElseIf CurrentRecipient = "Jerome" Then
RecipientFile = RecipientFile & FileName & ".txt"
Else
Exit Sub
End If
Dim Writer As IO.StreamWriter
Writer = New IO.StreamWriter(RecipientFile)
Writer.Write(MainRichTextBox.Text)
Writer.Close()
ShowtextRichTextBox.Text = (User & " : ") & MainRichTextBox.Text
MainRichTextBox.Clear()
End Sub
Thank you in advance ! :*
Your below code is just assigning (replacing) the latest value to the Rich TextBox,
ShowtextRichTextBox.Text = (User & " : ") & MainRichTextBox.Text
Instead, you should append the text as below,
ShowtextRichTextBox.Text &= (User & " : ") & MainRichTextBox.Text
Also, you can try the inbuild method of RichTextBox to append the text like, ShowtextRichTextBox.AppendText((User & " : ") & MainRichTextBox.Text)
Note: When appending, you should also add newline before the new text like, ShowtextRichTextBox.Text &= Environment.NewLine & (User & " : ") & MainRichTextBox.Text.
Modified code,
Private Sub saveMessage()
FileName = Format(Now, "MMddyyyyhhmmss")
Dim RecipientFile As String
If CurrentRecipient = "Edward" Then
RecipientFile = RecipientFolder & FileName & ".txt"
ElseIf CurrentRecipient = "Criziel" Then
RecipientFile = RecipientFolder & FileName & ".txt"
ElseIf CurrentRecipient = "Jerome" Then
RecipientFile = RecipientFile & FileName & ".txt"
Else
Exit Sub
End If
Dim Writer As IO.StreamWriter
Writer = New IO.StreamWriter(RecipientFile)
Writer.Write(MainRichTextBox.Text)
Writer.Close()
ShowtextRichTextBox.Text &= Environment.NewLine & (User & " : ") & MainRichTextBox.Text
MainRichTextBox.Clear()
End Sub
The problem of this script is that it shows an unknown error Message while running the script.
I called the function by echo method in my ftp which is "filezilla".
every thing is working fine as it logs into the server check for the path, open channel for data writing. Still dont know where is the problem
Function FTPUpload(sSite, sUsername, sPassword, sLocalFile, sRemotePath)
'This script is provided under the Creative Commons license located
'at http://creativecommons.org/licenses/by-nc/2.5/ . It may not
'be used for commercial purposes with out the expressed written consent
'of NateRice.com
Const OpenAsDefault = -2
Const FailIfNotExist = 0
Const ForReading = 1
Const ForWriting = 2
Set oFTPScriptFSO = CreateObject("Scripting.FileSystemObject")
Set oFTPScriptShell = CreateObject("WScript.Shell")
sRemotePath = Trim(sRemotePath)
sLocalFile = Trim(sLocalFile)
'----------Path Checks---------
'Here we willcheck the path, if it contains
'spaces then we need to add quotes to ensure
'it parses correctly.
If InStr(sRemotePath, " ") > 0 Then
If Left(sRemotePath, 1) <> """" And Right(sRemotePath, 1) <> """" Then
sRemotePath = """" & sRemotePath & """"
End If
End If
If InStr(sLocalFile, " ") > 0 Then
If Left(sLocalFile, 1) <> """" And Right(sLocalFile, 1) <> """" Then
sLocalFile = """" & sLocalFile & """"
End If
End If
'Check to ensure that a remote path was
'passed. If it's blank then pass a "\"
If Len(sRemotePath) = 0 Then
'Please note that no premptive checking of the
'remote path is done. If it does not exist for some
'reason. Unexpected results may occur.
sRemotePath = "\"
End If
'Check the local path and file to ensure
'that either the a file that exists was
'passed or a wildcard was passed.
If InStr(sLocalFile, "*") Then
If InStr(sLocalFile, " ") Then
FTPUpload = "Error: Wildcard uploads do not work if the path contains a " & _
"space." & vbCRLF
FTPUpload = FTPUpload & "This is a limitation of the Microsoft FTP client."
Exit Function
End If
ElseIf Len(sLocalFile) = 0 Or Not oFTPScriptFSO.FileExists(sLocalFile) Then
'nothing to upload
FTPUpload = "Error: File Not Found."
Exit Function
End If
'--------END Path Checks---------
'build input file for ftp command
sFTPScript = sFTPScript & "USER " & sUsername & vbCRLF
sFTPScript = sFTPScript & sPassword & vbCRLF
sFTPScript = sFTPScript & "cd " & sRemotePath & vbCRLF
sFTPScript = sFTPScript & "binary" & vbCRLF
sFTPScript = sFTPScript & "prompt n" & vbCRLF
sFTPScript = sFTPScript & "put " & sLocalFile & vbCRLF
sFTPScript = sFTPScript & "quit" & vbCRLF & "quit" & vbCRLF & "quit" & vbCRLF
sFTPTemp = oFTPScriptShell.ExpandEnvironmentStrings("%TEMP%")
sFTPTempFile = sFTPTemp & "\" & oFTPScriptFSO.GetTempName
sFTPResults = sFTPTemp & "\" & oFTPScriptFSO.GetTempName
'Write the input file for the ftp command
'to a temporary file.
Set fFTPScript = oFTPScriptFSO.CreateTextFile(sFTPTempFile, True)
fFTPScript.WriteLine(sFTPScript)
fFTPScript.Close
Set fFTPScript = Nothing
oFTPScriptShell.Run "%comspec% /c FTP -n -s:" & sFTPTempFile & " " & sSite & _
" > " & sFTPResults, 0, TRUE
Wscript.Sleep 1000
'Check results of transfer.
Set fFTPResults = oFTPScriptFSO.OpenTextFile(sFTPResults, ForReading, _
FailIfNotExist, OpenAsDefault)
sResults = fFTPResults.ReadAll
fFTPResults.Close
oFTPScriptFSO.DeleteFile(sFTPTempFile)
oFTPScriptFSO.DeleteFile (sFTPResults)
If InStr(sResults, "226 Transfer complete.") > 0 Then
FTPUpload = True
ElseIf InStr(sResults, "File not found") > 0 Then
FTPUpload = "Error: File Not Found"
ElseIf InStr(sResults, "cannot log in.") > 0 Then
FTPUpload = "Error: Login Failed."
Else
FTPUpload = "Error: Unknown."
End If
Set oFTPScriptFSO = Nothing
Set oFTPScriptShell = Nothing
WScript.Echo "Process Completed (" & Now & ")"
End Function
I tried to get output in console program, but i got error
maybe I think that the error is about 'deadlock'
I pass night without sleep doing search solution that this error, I can't find
anyone can help me?
Someone tell me about the solution to fix it, it seems to make inherit system.
and he refer : http://programming.nullanswer.com/question/27270022
but this is java not vb.net.
Error Message:
'CTextConsoleWin32::GetLien: !GetNumberOfConsoleInputEvents'
Dim cmdCommand As String
getgame()
Serverlog.Clear()
Serverlog.Text += "ServerName : " & SelectedServer.Item(8) & " / " & "Server Download Path : " & SelectedServer.Item(9) & vbCrLf
Dim mapname As String = Split(SelectedServer.Item(2), ".bsp")(0)
cmdCommand = "-console -game " & SelectedServerGame & " -tickrate " & SelectedServer.Item(5) & " -port " & SelectedServer.Item(11) & " -maxplayers_override " & SelectedServer.Item(4) & " +map " & mapname
Serverlog.Text += (cmdCommand) & vbCrLf
Dim start_info As New ProcessStartInfo()
start_info.FileName = SelectedServer.Item(0)
start_info.UseShellExecute = False
'start_info.CreateNoWindow = True
start_info.RedirectStandardError = True
start_info.RedirectStandardOutput = True
start_info.RedirectStandardInput = True
'start_info.WindowStyle = ProcessWindowStyle.Hidden
start_info.Arguments = cmdCommand
Dim proc As New Global.System.Diagnostics.Process
proc.StartInfo = start_info
proc.Start()
Dim std_out As StreamReader = proc.StandardOutput
Do
proc.WaitForInputIdle()
Dim line As String = Await std_out.ReadLineAsync()
'Serverlog.Text += std_out.ReadLine & vbCrLf
Serverlog.Invoke(Sub() Serverlog.Text += line & vbCrLf)
Loop While proc.HasExited = False