How to skip directory or file when UnauthorizedAccessException - vb.net

I am writing an application which checks the computer for viruses from a specific path(including system paths, such as the Windows directory, Program Files, Application Data, etc)
The user will click a button "Start scan", will begin checking of system files(including Windows/ProgramFiles directories) for viruses, comparing files to MD5 hashes from a text files named "viruslist.txt"
However, I am having some issues with UnauthorizedAccessException errors. The application will stop when it detects a file which cannot be accessed.
I want the application to skip the denied files and move on to the next file in the specific path.
My code is as it follows:
Backgroundworker Do Work code:
Try
For Each file As String In IO.Directory.EnumerateFiles(FolderBrowserDialog3.SelectedPath, IO.SearchOption.AllDirectories).Union(IO.Directory.EnumerateFiles(FolderBrowserDialog4.SelectedPath, "*", IO.SearchOption.AllDirectories))
Try
Dim scanbox As New TextBox
Dim read As String = My.Computer.FileSystem.ReadAllText(System.AppDomain.CurrentDomain.BaseDirectory & "viruslist.txt")
scanbox.Text = read.ToString
Dim md5 As MD5CryptoServiceProvider = New MD5CryptoServiceProvider
Dim f As FileStream = New FileStream(file, FileMode.Open, FileAccess.Read, FileShare.Read, 8192)
f = New FileStream(file, FileMode.Open, FileAccess.Read, FileShare.Read, 8192)
md5.ComputeHash(f)
Dim hash As Byte() = md5.Hash
Dim buff As StringBuilder = New StringBuilder
Dim hashByte As Byte
For Each hashByte In hash
buff.Append(String.Format("{0:X2}", hashByte))
Next
If scanbox.Text.Contains(buff.ToString) Then
AddListItem2(ListBox2, "" & file & "")
End If
Catch ex As Exception
End Try
' SetLabelText_ThreadSafe(Me.Label1, "" & file & "")
If (BackgroundWorker1.CancellationPending = True) Then
e.Cancel = True
Exit For
End If
SetLabelText_ThreadSafe(Me.Labelscannedfiles, file & "")
int = int + 1
SetLabelText_ThreadSafe(Me.Label2, int & " Out Of " & filecount & "")
Dim pct As Integer = (int / filecount * 100)
BackgroundWorker1.ReportProgress(pct)
Next file
Catch ex as unauthorizedaccessexception
Also, the button code(start scan):
FolderBrowserDialog3.SelectedPath = Environment.GetFolderPath(Environment.SpecialFolder.Windows)
Try
For Each strDir As String In
System.IO.Directory.GetDirectories(FolderBrowserDialog3.SelectedPath)
For Each strFile As String In System.IO.Directory.GetFiles(strDir)
Next
Next
Catch ex As Exception
Listbox2- used to display detected infected objects.
I've tried the following:
Changing the app's manifest to "requireAdministrator" and "highestavailable" ;
Disabling UAC .
Nothing worked so far!
UPDATE
Thanks to JQSOFT for providing the solution to my issue. The below solution will surely help a lot of people who have the same issue I had. This question has been solved.

Here's some points.
'Set this to True in the Cancel button...
Private cancel As Boolean
Sub New()
InitializeComponent()
'...
BackgroundWorker1.WorkerReportsProgress = True
BackgroundWorker1.WorkerSupportsCancellation = True
End Sub
Use this iterator function to get the authorized files and folders:
Private Iterator Function IterateFolders(startDir As String,
includeFiles As Boolean,
includeSubDir As Boolean) As IEnumerable(Of String)
Try
For Each dirName In Directory.EnumerateDirectories(startDir)
Yield dirName
Try
If includeFiles Then
For Each fileName In Directory.EnumerateFiles(startDir)
Yield fileName
Next
End If
If includeSubDir Then
For Each subDir In IterateFolders(dirName, includeFiles, includeSubDir)
Yield subDir
Next
End If
Catch ex As UnauthorizedAccessException
Catch ex As Exception
End Try
Next
Catch ex As UnauthorizedAccessException
Catch ex As Exception
End Try
End Function
The start scan button
Private Sub Scan_Click(sender As Object, e As EventArgs) Handles Scan.Click
If BackgroundWorker1.IsBusy Then Return
Using fbd As New FolderBrowserDialog
If fbd.ShowDialog = DialogResult.OK Then
cancel = False
'...
BackgroundWorker1.RunWorkerAsync(fbd.SelectedPath)
End If
End Using
End Sub
The BackgroundWorker events:
Private Sub BackgroundWorker1_DoWork(sender As Object,
e As DoWorkEventArgs) Handles BackgroundWorker1.DoWork
Dim dir = e.Argument.ToString
For Each file In IterateFolders(dir, True, True).
Where(Function(f) IO.File.Exists(f)) '<- To get the files only.
If cancel Then
e.Cancel = True
Return
End If
Try
Dim b As Boolean = False
Using md5 As New MD5CryptoServiceProvider,
f As FileStream = New FileStream(file,
FileMode.Open,
FileAccess.Read,
FileShare.Read, 8192)
md5.ComputeHash(f)
Dim hash As Byte() = md5.Hash
Dim buff As New StringBuilder
Dim hashByte As Byte
For Each hashByte In hash
buff.Append(String.Format("{0:X2}", hashByte))
Next
b = IO.File.ReadLines("...FullPathOf\viruslist.txt").
Any(Function(x) x = buff.ToString)
End Using
'The main thread...
Invoke(New Action(Sub()
If b Then ListBox2.Items.Add(file)
Labelscannedfiles.Text = ....
Label2.Text = $"{int} Out of {filecount}"
End Sub))
'Code to update the progress here...
Catch ex As IOException
Catch ex As Exception
End Try
Next
End Sub
Private Sub BackgroundWorker1_ProgressChanged(sender As Object,
e As ProgressChangedEventArgs) _
Handles BackgroundWorker1.ProgressChanged
'Update the progress...
End Sub
Private Sub BackgroundWorker1_RunWorkerCompleted(sender As Object,
e As RunWorkerCompletedEventArgs) _
Handles BackgroundWorker1.RunWorkerCompleted
If e.Error IsNot Nothing Then
'An error occurred
ElseIf e.Cancelled Then
'Operation canceled...
Else
'On success ....
End If
End Sub

Related

Access denied during production

The code below works as intended in DEBUG with no errors. I input my search parameters, the record returns and populates all textboxes and loads the PDF file into the AxAcroPDF1 viewer.
However, after I compile and install the program I am receiving the error "Access to the path 'C:\Program Files (x86)\NAME OF PROGRAM\temp.file' is denied'
This only occurs when I search for a record and the PDF (in Binary format in the DB) to that record is supposed to load fails with the error message listed above. How can I resolve the permissions level (assuming this is the issue) to allow for the PDF to load? The area of concern presumably and more specifically is the LoadPDF() sub.
My code is as follows:
Imports System.Data.SqlClient
Public Class LoadDocs
Private DV As DataView
Private currentRow As String
Private Sub LoadDocs_Load(sender As Object, e As EventArgs) Handles MyBase.Load
'TODO: This line of code loads data into the 'DocDataset.Documents_Table' table. You can move, or remove it, as needed.
Documents_TableTableAdapter.Fill(DocDataset.Documents_Table)
'Loads last record on to form
DocumentsTableBindingSource.Position = DocDataset.Documents_Table.Rows.Count - 1
DV = New DataView(DocDataset.Documents_Table)
'LoadPDF()
End Sub
Private Sub BtnOpenPDF_Click(sender As Object, e As EventArgs) Handles btnOpenPDF.Click
tbRecNumb.Clear()
tbFileName.Clear()
tbPetsLoadNumber.Clear()
tbBrokerLoadNumber.Clear()
tbFilePath.Clear()
Dim CurYear As String = CType(Now.Year(), String)
On Error Resume Next
OpenFileDialog1.Filter = "PDF Files(*.pdf)|*.pdf"
OpenFileDialog1.ShowDialog()
AxAcroPDF1.src = OpenFileDialog1.FileName
tbFilePath.Text = OpenFileDialog1.FileName
Dim filename As String = tbFilePath.Text.ToString
tbFileName.Text = filename.Substring(Math.Max(0, filename.Length - 18))
Dim loadnumber As String = tbFileName.Text
tbPetsLoadNumber.Text = loadnumber.Substring(7, 7)
End Sub
' Search for PETS Load Number, Broker Load Numberthen load record if found
Private Sub BtnSearchBtn_MouseEnter(sender As Object, e As EventArgs) Handles btnSearch.MouseEnter
Cursor = Cursors.Hand
btnSearch.BackgroundImage = My.Resources.ButtonDwn_Teal_Trans
End Sub
Private Sub BtnSearchBtn_MouseLeave(sender As Object, e As EventArgs) Handles btnSearch.MouseLeave
Cursor = Cursors.Default
btnSearch.BackgroundImage = My.Resources.Button_Teal_Trans
End Sub
Private Sub TbSearchInput_KeyDown(sender As Object, e As KeyEventArgs) Handles tbSearchInput.KeyDown
Cursor = Cursors.Hand
If e.KeyCode = Keys.Enter Then
Search()
End If
End Sub
Private Sub BtnSearch_Click(sender As Object, e As EventArgs) Handles btnSearch.Click
btnSearch.BackgroundImage = My.Resources.ButtonClk_Teal_Trans
Cursor = Cursors.Hand
Search()
End Sub
Private Sub Search()
Cursor = Cursors.WaitCursor
If cbColName.Text = "SEARCH BY:" Then
MeMsgBoxSearchCriteria.ShowDialog()
Else : lblSearchResults.Items.Clear()
Select Case DocDataset.Documents_Table.Columns(cbColName.Text).DataType
Case GetType(Integer)
DV.RowFilter = cbColName.Text & " = " & tbSearchInput.Text.Trim
Case GetType(Date)
DV.RowFilter = cbColName.Text & " = #" & tbSearchInput.Text.Trim & "#"
Case Else
DV.RowFilter = cbColName.Text & " LIKE '*" & tbSearchInput.Text.Trim & "*'"
End Select
If DV.Count > 0 Then
For IX As Integer = 0 To DV.Count - 1
lblSearchResults.Items.Add(DV.Item(IX)("PETS_LOAD_NUMBER"))
Next
If DV.Count = 1 Then
lblSearchResults.SelectedIndex = 0
Dim ix As Integer = DocumentsTableBindingSource.Find("PETS_LOAD_NUMBER", CInt(lblSearchResults.SelectedItem.ToString))
DocumentsTableBindingSource.Position = ix
LoadPDF()
Else
lblSearchResults.Visible = True
lblSearchResults.BringToFront()
End If
Else
' Display a message box notifying users the record cannot be found.
MeMsgBoxNoSearch.ShowDialog()
End If
End If
Cursor = Cursors.Default
End Sub
Private Sub LblSearchResults_SelectedIndexChanged(sender As Object, e As EventArgs) Handles lblSearchResults.SelectedIndexChanged
Dim ix As Integer = DocumentsTableBindingSource.Find("PETS_LOAD_NUMBER", CInt(lblSearchResults.SelectedItem.ToString))
DocumentsTableBindingSource.Position = ix
lblSearchResults.Visible = False
End Sub
Private Sub LoadPDF()
Dim temp = Environment.GetEnvironmentVariable("TEMP", EnvironmentVariableTarget.User)
If File.Exists(Application.StartupPath() & "\temp.file") = True Then
AxAcroPDF1.src = "blank.pdf"
My.Computer.FileSystem.DeleteFile(Application.StartupPath() & "\temp.file")
End If
Dim cmd As New SqlCommand
cmd.CommandText = "SELECT DOCUMENTS FROM Documents_Table WHERE PETS_LOAD_NUMBER = #pl"
cmd.Parameters.AddWithValue("#pl", tbPetsLoadNumber.Text)
cmd.CommandType = CommandType.Text
cmd.Connection = New SqlConnection With {
.ConnectionString = My.MySettings.Default.PETS_DatabaseConnectionString
}
Dim Buffer As Byte()
cmd.Connection.Open()
Buffer = cmd.ExecuteScalar
cmd.Connection.Close()
File.WriteAllBytes(Application.StartupPath() & "\temp.file", Buffer)
'DATA READER
AxAcroPDF1.src = Application.StartupPath() & "\temp.file"
End Sub
Private Sub DocumentsTableBindingSource_PositionChanged(sender As Object, e As EventArgs) Handles DocumentsTableBindingSource.PositionChanged
Try
currentRow = DocDataset.Documents_Table.Item(DocumentsTableBindingSource.Position).ToString
Catch ex As Exception
MessageBox.Show(ex.Message)
End Try
End Sub
Private Sub BtnSavePDF_Click(sender As Object, e As EventArgs) Handles btnSavePDF.Click
If tbPetsLoadNumber.Text.Length = 0 Then
MessageBox.Show("Please enter a PETS Load Number", "Missing Load Number", MessageBoxButtons.OK, MessageBoxIcon.Exclamation)
Exit Sub
ElseIf tbBrokerLoadNumber.Text.Length = 0 Then
MessageBox.Show("Please enter a Broker Load Number", "Missing Load Number", MessageBoxButtons.OK, MessageBoxIcon.Exclamation)
Exit Sub
ElseIf tbFileName.Text.Length = 0 Then
MessageBox.Show("Please enter a Filename", "Missing Filename", MessageBoxButtons.OK, MessageBoxIcon.Exclamation)
Exit Sub
End If
Try
Using OpenFileDialog As OpenFileDialog = OpenFileDialog1()
If (OpenFileDialog.ShowDialog(Me) = DialogResult.OK) Then
tbFilePath.Text = OpenFileDialog.FileName
Else 'Cancel
Exit Sub
End If
End Using
'Call Upload Images Or File
Dim sFileToUpload As String = ""
sFileToUpload = LTrim(RTrim(tbFilePath.Text))
'Initialize byte array with a null value initially.
Dim data As Byte() = Nothing
'Use FileInfo object to get file size.
Dim fInfo As New FileInfo(tbFilePath.Text)
Dim numBytes As Long = fInfo.Length
'Open FileStream to read file
Dim fStream As New FileStream(tbFilePath.Text, FileMode.Open, FileAccess.Read)
'Use BinaryReader to read file stream into byte array.
Dim br As New BinaryReader(fStream)
'Supply number of bytes to read from file.
'In this case we want to read entire file. So supplying total number of bytes.
data = br.ReadBytes(CInt(numBytes))
'Insert the details into the database
Dim cmd As New SqlCommand
cmd.CommandText = "INSERT INTO Documents_Table (BROKER_LOAD_NUMBER, PDF_FILENAME, PETS_LOAD_NUMBER, DOCUMENTS)
VALUES (#bl, #fn, #pl, #pdf)"
cmd.Parameters.Add("#fn", SqlDbType.NVarChar, 50).Value = tbFileName.Text
cmd.Parameters.Add("#pl", SqlDbType.Int).Value = tbPetsLoadNumber.Text
cmd.Parameters.Add("#bl", SqlDbType.NVarChar, 20).Value = tbBrokerLoadNumber.Text
cmd.Parameters.Add("#pdf", SqlDbType.VarBinary, -1).Value = data
cmd.CommandType = CommandType.Text
cmd.Connection = New SqlConnection With {
.ConnectionString = My.MySettings.Default.PETS_DatabaseConnectionString
}
cmd.Connection.Open()
cmd.ExecuteNonQuery()
cmd.Connection.Close()
MsgBox("File Successfully Imported to Database")
Catch ex As Exception
MessageBox.Show(ex.ToString())
End Try
End Sub
End Class
In your function LoadPDF you create a reference to tempdir and then don't use it. Instead, you use Application.StartupPath() which will point to C:\Programs(x86) and is usually not writeable without admin rights.
But why don't you use your temp dir:
Dim temp = SpecialDirectories.Temp 'more robust approach to get tempdir
If File.Exists(temp & "\temp.file") = True Then
AxAcroPDF1.src = "blank.pdf"
My.Computer.FileSystem.DeleteFile(temp & "\temp.file")
End If
...
File.WriteAllBytes(temp & "\temp.file", Buffer)
'DATA READER
AxAcroPDF1.src = temp & "\temp.file"

Incorrect progressbar value reported by the backgroundworker

I build an app, which searches for different files through the computer, including Windows, ProgramFiles, etc folders.
I've already done with the 'recursive' file search and it works now, this means all files/folders which are inaccessible will be skipped and the software will move on with the other available folders/files. But now, I have other issues...
The problem is that, for some odd reason, the application does not correctly report the progressbar value accordingly to the progress made in searching the files. This means that, the file search continues, BUT the progressbar is already 100%. The progressbar value SHOULD be 100% when the file search has been successfully completed.
====other code is already here ====
Dim int As Integer = 0
Dim filecount As Integer = 0
Private Function GetFilesRecursive(ByVal path As String) As List(Of String)
Dim lstResult As New List(Of String)
Dim stkStack As New Stack(Of String)
stkStack.Push(path)
Do While (stkStack.Count > 0)
Dim strDirectory As String = stkStack.Pop
Try
lstResult.AddRange(Directory.GetFiles(strDirectory, "*.*"))
Dim strDirectoryName As String
For Each strDirectoryName In Directory.GetDirectories(strDirectory)
stkStack.Push(strDirectoryName)
Next
Catch ex As Exception
End Try
Loop
Return lstResult
End Function
Private Sub BackgroundWorker1_DoWork(ByVal sender As Object, ByVal e As System.ComponentModel.DoWorkEventArgs) Handles Quickscan.DoWork
Try
Dim i As Integer
Dim files As List(Of String) = GetFilesRecursive(FolderBrowserDialog1.SelectedPath)
For Each file As String In files
Try
Dim scanbox As New TextBox
Dim read As String = My.Computer.FileSystem.ReadAllText(System.AppDomain.CurrentDomain.BaseDirectory & "db1.db")
scanbox.Text = read.ToString
Dim md5 As MD5CryptoServiceProvider = New MD5CryptoServiceProvider
Dim f As FileStream = New FileStream(file, FileMode.Open, FileAccess.Read, FileShare.Read, 8192)
f = New FileStream(file, FileMode.Open, FileAccess.Read, FileShare.Read, 8192)
md5.ComputeHash(f)
Dim hash As Byte() = md5.Hash
Dim buff As StringBuilder = New StringBuilder
Dim hashByte As Byte
For Each hashByte In hash
buff.Append(String.Format("{0:X2}", hashByte))
Next
If scanbox.Text.Contains(buff.ToString) Then
AddListItem(Listbox2, "" & file)
AddListItem2(Listbox2, "" & file & "")
End If
Catch ex As Exception
End Try
If (Backgroundworker1.CancellationPending = True) Then
e.Cancel = True
Exit For
End If
SetLabelText_ThreadSafe(Me.Labelscannedfiles, file & "")
i = i + 1
SetLabelText_ThreadSafe(Me.Label2, i)
Dim pct As Integer = CInt(CDbl(i) / CDbl(files.Count) * 100)
Backgroundworker1.ReportProgress(pct)
Next file
Catch ex As UnauthorizedAccessException
End Try
Private Sub BackgroundWorker1_ProgressChanged(ByVal sender As Object, ByVal e As System.ComponentModel.ProgressChangedEventArgs) Handles Backgroundworker1.ProgressChanged
Label28.Text = "Computer scan is in progress... Please wait"
ProgressBar1.Value = e.ProgressPercentage / 100
Any solution or help would be highly appreciated!
In your DoWork() method...
Change:
For Each file As String In GetFilesRecursive(FolderBrowserDialog1.SelectedPath)
To:
Dim i As Integer ' <- you didn't actually declare a counter before
Dim files As List(Of String) = GetFilesRecursive(FolderBrowserDialog1.SelectedPath)
For Each file As String In files
Now you can get the count from "files" and use that in your percentage calculation:
i = i + 1 ' <-- increment our "i" counter
SetLabelText_ThreadSafe(Me.Label2, i)
Dim pct As Integer = CInt(CDbl(i) / CDbl(files.Count) * 100)
backgroundworker1.ReportProgress(pct)

Error : file is being used by another process

I have a problem where it says that a file is already being used by another process
But I am pretty sure it's not being used anywhere else..
Imports System.IO
Public Class Browse
Private Sub add_Click(sender As Object, e As EventArgs) Handles add.Click
Dim Files As New OpenFileDialog
Dim Folder As New FolderBrowserDialog
Dim Filelist As String = "C:\Program Files\FTP-Sync\Files.txt"
Dim FileP As String = ""
Dim list() As String = IO.File.ReadAllLines(Filelist)
If fileb.Checked Then
Try
If System.IO.File.Exists(Filelist) = True And Files.ShowDialog = Windows.Forms.DialogResult.OK Then
FileP = Files.FileName
End If
Catch ex As Exception
MsgBox(ex.Message)
End Try
End If
If folderb.Checked Then
Try
If System.IO.File.Exists(Filelist) = True And Folder.ShowDialog = Windows.Forms.DialogResult.OK Then
FileP = Folder.SelectedPath
End If
Catch ex As Exception
MsgBox(ex.Message)
End Try
End If
pathtxt.Text = FileP
End Sub
Private Sub ok_Click(sender As Object, e As EventArgs) Handles ok.Click
Dim Filelist As String = "C:\Program Files\FTP-Sync\Files.txt"
Dim writer As StreamWriter = New StreamWriter(Filelist)
Dim FileP As String = ""
Try
If pathtxt.Text = "" Then
MsgBox("No folder or file has been choosen")
Else
writer = File.AppendText(Filelist)
writer.WriteLine(pathtxt.Text)
pathtxt.Text = FileP
writer.Close()
Me.Hide()
End If
Catch ex As Exception
MsgBox(ex.Message)
End Try
End Sub
Private Sub cancel_Click(sender As Object, e As EventArgs) Handles cancel.Click
Me.Hide()
End Sub
Private Sub Browse_Load(sender As Object, e As EventArgs) Handles MyBase.Load
End Sub
End Class
Thanks in advance!
It was because of this:
Dim writer As StreamWriter = New StreamWriter(Filelist)
i changed it to
Dim writer As StreamWriter
and it work like a charm.. dont know if it is the right way.. but it worked.

WebBrowser, handle pdf load complete

I was wondering if anyone knew an easy way to have .pdf files trigger the readystate when loaded. I'm building a program to open url's and take screenshots, then put them in excel.
The web browser will load html documents correctly, but gets stuck in While Not pageready when loading .pdf files. The browser control correctly renders the .pdf.
Private Sub btngo_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles btngo.Click
Dim file As String
Dim Obj As New Object
Dim result As String
Dim sheet As String = "sheet1"
Dim xlApp As New Excel.Application
If lblpath.Text <> "" Then
file = lblpath.Text
Dim xlWorkBook = xlApp.Workbooks.Open(file)
Dim xlWorkSheet = xlWorkBook.Worksheets(sheet)
Dim range = xlWorkSheet.UsedRange
ProgressBar1.Value = 0
For rCnt = 4 To range.Rows.Count
'url cell
Obj = CType(range.Cells(rCnt, 2), Excel.Range)
' Obj.value now contains the value in the cell..
Try
' Creates an HttpWebRequest with the specified URL.
Dim myHttpWebRequest As HttpWebRequest = CType(WebRequest.Create(Obj.value), HttpWebRequest)
' Sends the request and waits for a response.
Dim myHttpWebResponse As HttpWebResponse = CType(myHttpWebRequest.GetResponse(), HttpWebResponse)
If myHttpWebResponse.StatusCode = HttpStatusCode.OK Then
result = myHttpWebResponse.StatusCode
WebBrowser1.ScrollBarsEnabled = False
WebBrowser1.Navigate(myHttpWebRequest.RequestUri)
WaitForPageLoad()
CaptureWebBrowser(WebBrowser1)
End If
' Release the resources of the response.
myHttpWebResponse.Close()
Catch ex As WebException
result = (ex.Message)
Catch ex As Exception
result = (ex.Message)
End Try
RichTextBox1.AppendText(result & " " & Obj.value & vbNewLine)
If radpre.Checked = True Then
range.Cells(rCnt, 3).value = result
ElseIf radcob.Checked = True Then
range.Cells(rCnt, 4).value = result
ElseIf radpost.Checked = True Then
range.Cells(rCnt, 5).value = result
End If
ProgressBar1.Value = rCnt / range.Rows.Count * 100
Next
With xlApp
.DisplayAlerts = False
xlWorkBook.SaveAs(lblpath.Text.ToString)
.DisplayAlerts = True
End With
xlWorkBook.Close()
xlApp.Quit()
'reclaim memory
Marshal.ReleaseComObject(xlApp)
xlApp = Nothing
End If
End Sub
Private Function CaptureWebBrowser(ByVal wb As WebBrowser) As Image
Try
Dim hBitmap As Bitmap = New Bitmap(wb.Width, wb.Height)
wb.DrawToBitmap(hBitmap, wb.Bounds)
Dim img As Image = hBitmap
Return img
Catch ex As Exception
MessageBox.Show(ex.Message)
End Try
Return Nothing
End Function
Private Sub WaitForPageLoad()
AddHandler WebBrowser1.DocumentCompleted, New WebBrowserDocumentCompletedEventHandler(AddressOf PageWaiter)
While Not pageready
Application.DoEvents()
End While
pageready = False
End Sub
Private Sub PageWaiter(ByVal sender As Object, ByVal e As WebBrowserDocumentCompletedEventArgs)
If WebBrowser1.ReadyState = WebBrowserReadyState.Complete Then
pageready = True
RemoveHandler WebBrowser1.DocumentCompleted, New WebBrowserDocumentCompletedEventHandler(AddressOf PageWaiter)
End If
End Sub
update to resolved
I'm very happy with the feedback. I really like like the answer Noseratio provided. I was not aware using the code pattern as not in best practices. When opening a .pdf or any other document not web based readyState will never change from 0. Seeing how this program is simply a way for me not to work at work, I'm satisfied with only capturing .html and .htm.
My requirements were
open excel document
parse links located in excel document
determine response code
write response code and if possible screenshot to excel
The program parses and retrieves feedback far faster then I would be able to do manually. Screenshots of .html and .htm provide non-technical viewers of the excel file proof of successful migration from production to COB, and back to production environments.
This code as stated by Noseratio does not follow best practices, nor is it high quality. This is a quick and dirty implementation.
Option Infer On
Imports Microsoft.Office.Interop
Imports System.Net
Imports System.Runtime.InteropServices
Public Class Form1
Public Property pageready As Boolean
Private Sub OpenToolStripMenuItem_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles OpenToolStripMenuItem.Click
OpenFileDialog1.ShowDialog()
End Sub
Private Sub OpenFileDialog1_FileOk(ByVal sender As System.Object, ByVal e As System.ComponentModel.CancelEventArgs) Handles OpenFileDialog1.FileOk
lblpath.Text = OpenFileDialog1.FileName.ToString
End Sub
Private Sub btngo_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles btngo.Click
Dim file As String
Dim Obj As New Object
Dim result As String
Dim sheet As String = "sheet1"
Dim xlApp As New Excel.Application
Dim img As Bitmap
Dim path As String = "C:\Documents and Settings\user\My Documents\Visual Studio 2010\Projects\COB-HTML-Tool\COB-HTML-Tool\bin\Debug\tmp.bmp"
If lblpath.Text <> "" Then
file = lblpath.Text
Dim xlWorkBook = xlApp.Workbooks.Open(file)
Dim xlWorkSheet = xlWorkBook.Worksheets(sheet)
Dim range = xlWorkSheet.UsedRange
ProgressBar1.Value = 0
For rCnt = 4 To range.Rows.Count
'url cell
Obj = CType(range.Cells(rCnt, 2), Excel.Range)
' Obj.value now contains the value in the cell..
Try
' Creates an HttpWebRequest with the specified URL.
Dim myHttpWebRequest As HttpWebRequest = CType(WebRequest.Create(Obj.value), HttpWebRequest)
' Sends the request and waits for a response.
Dim myHttpWebResponse As HttpWebResponse = CType(myHttpWebRequest.GetResponse(), HttpWebResponse)
If myHttpWebResponse.StatusCode = HttpStatusCode.OK Then
result = myHttpWebResponse.StatusCode
Dim len As Integer = myHttpWebRequest.RequestUri.ToString.Length - 4
If myHttpWebRequest.RequestUri.ToString.Substring(len) = ".htm" Or
myHttpWebRequest.RequestUri.ToString.Substring(len - 1) = ".html" Or
myHttpWebRequest.RequestUri.ToString.Substring(len) = ".asp" Then
WebBrowser1.Navigate(myHttpWebRequest.RequestUri)
WaitForPageLoad()
img = CaptureWebBrowser(WebBrowser1)
img.Save(path)
End If
End If
' Release the resources of the response.
myHttpWebResponse.Close()
Catch ex As WebException
result = (ex.Message)
Catch ex As Exception
result = (ex.Message)
End Try
RichTextBox1.AppendText(result & " " & Obj.value & vbNewLine)
If radpre.Checked = True Then
range.Cells(rCnt, 3).value = result
If img Is Nothing Then
Else
If Dir(path) <> "" Then
range.Cells(rCnt, 4).Select()
Dim opicture As Object
opicture = xlApp.ActiveSheet.Pictures.Insert(path)
opicture.ShapeRange.LockAspectRatio = True
opicture.ShapeRange.width = 170
opicture.ShapeRange.height = 170
My.Computer.FileSystem.DeleteFile(path)
End If
End If
ElseIf radcob.Checked = True Then
range.Cells(rCnt, 5).value = result
If img Is Nothing Then
Else
If Dir(path) <> "" Then
range.Cells(rCnt, 6).Select()
Dim opicture As Object
opicture = xlApp.ActiveSheet.Pictures.Insert(path)
opicture.ShapeRange.LockAspectRatio = True
opicture.ShapeRange.width = 170
opicture.ShapeRange.height = 170
My.Computer.FileSystem.DeleteFile(path)
End If
End If
ElseIf radpost.Checked = True Then
range.Cells(rCnt, 7).value = result
If img Is Nothing Then
Else
If Dir(path) <> "" Then
range.Cells(rCnt, 8).Select()
Dim opicture As Object
opicture = xlApp.ActiveSheet.Pictures.Insert(path)
opicture.ShapeRange.LockAspectRatio = True
opicture.ShapeRange.width = 170
opicture.ShapeRange.height = 170
My.Computer.FileSystem.DeleteFile(path)
End If
End If
End If
ProgressBar1.Value = rCnt / range.Rows.Count * 100
Next
With xlApp
.DisplayAlerts = False
xlWorkBook.SaveAs(lblpath.Text.ToString)
.DisplayAlerts = True
End With
xlWorkBook.Close()
xlApp.Quit()
'reclaim memory
Marshal.ReleaseComObject(xlApp)
xlApp = Nothing
End If
End Sub
Private Function CaptureWebBrowser(ByVal wb As WebBrowser) As Image
Try
wb.ScrollBarsEnabled = False
Dim hBitmap As Bitmap = New Bitmap(wb.Width, wb.Height)
wb.DrawToBitmap(hBitmap, wb.Bounds)
Dim img As Image = hBitmap
Return img
Catch ex As Exception
MessageBox.Show(ex.Message)
End Try
Return Nothing
End Function
Private Sub WaitForPageLoad()
AddHandler WebBrowser1.DocumentCompleted, New WebBrowserDocumentCompletedEventHandler(AddressOf PageWaiter)
While Not pageready
Application.DoEvents()
System.Threading.Thread.Sleep(200)
End While
pageready = False
End Sub
Private Sub PageWaiter(ByVal sender As Object, ByVal e As WebBrowserDocumentCompletedEventArgs)
If WebBrowser1.ReadyState = WebBrowserReadyState.Complete Then
pageready = True
RemoveHandler WebBrowser1.DocumentCompleted, New WebBrowserDocumentCompletedEventHandler(AddressOf PageWaiter)
End If
End Sub
End Class
Unfortunately, you won't be able to use webBrowser.DrawToBitmap to get a snapshot of the PDF view. At the time of writing this, Adobe Acrobat Reader ActiveX control doesn't support rendering on a custom device context, so this method won't work, as well as sending WM_PRINT or calling IViewObject::Draw, either directly on the Reader ActiveX object on via WebBrowser (I tried that, and I'm not alone). The proper solution would be to use a 3rd party PDF rendering component.
On a side note, you should avoid using code pattern like this:
While Not pageready
Application.DoEvents()
End While
It's a busy waiting tight loop, consuming CPU cycles in vain. At least, put some Thread.Sleep(200) inside the loop, but overall you should avoid using Application.DoEvents too.

Backgroundworker Progressbar freezes

So I've finally got this to almost work but now every few times I test the process the form and the progressbar freeze. I'm also sure there are much more efficient ways of doing this so any constructive criticism would be greatly appreciated.
This is the coding for one page of a program that allows the user to click one button to download and install one application and then press the next button to download and install a different application:
Imports System.Net.WebRequestMethods
Public Class Software
'Open link in external browser
Public Sub HandleRequestNavigate(ByVal sender As Object, ByVal e As RequestNavigateEventArgs)
Process.Start(New ProcessStartInfo(e.Uri.AbsoluteUri))
e.Handled = True
End Sub
'Declarations
Shared progressamc As New Progress
Shared progresscti As New ProgressCTI
WithEvents startcti As New Process
WithEvents startamc As New Process
WithEvents startsfstb As New Process
WithEvents amcworker As New ComponentModel.BackgroundWorker
WithEvents ctiworker As New ComponentModel.BackgroundWorker
Dim ProgressBarAMC As Object = Progress.ProgressBar1
Dim blprgrsAMC As Object = Progress.blprgrs
Dim ProgressBarCTI As Object = progresscti.ProgressBar1
Dim blprgrsCTI As Object = progresscti.blprgrs
'FTP Values
Const host As String = "ftp://10.167.16.80/"
Const username As String = "anonymous"
Const password As String = ""
'AMC File Put/Get
Const localfileamc As String = "C:\AMC.exe"
Const Remotefileamc As String = "Bin/AMC.exe"
'CTI File Put/Get
Const localfilecti As String = "C:\CTI.exe"
Const Remotefilecti As String = "Bin/CTI.exe"
'On Init
Public Sub New()
InitializeComponent()
amcworker.WorkerReportsProgress = True
amcworker.WorkerSupportsCancellation = True
ctiworker.WorkerReportsProgress = True
ctiworker.WorkerSupportsCancellation = True
End Sub
'Install AMC Button
Private Sub ButtonAMC(sender As Object, e As RoutedEventArgs)
Dim butt1 As Button = DirectCast(sender, Button)
butt1.IsEnabled = False
Dispatcher.BeginInvoke(New Action(AddressOf progressamc_Show))
AddHandler Progress.Cancel_Click, AddressOf myProcessamc_Exited
amcworker.RunWorkerAsync()
End Sub
'Open Dialog
Private Sub progressamc_Show()
Try
progressamc.ShowDialog()
Catch ex As Exception
MessageBox.Show("An error has occurred during the process:" & vbCrLf & vbCrLf & ex.Message & vbCrLf & vbCrLf & "Please close the application and try again." _
& vbCrLf & "If you continue to encounter this error please Email")
End Try
End Sub
'FTP - Download
Private Sub ftpseshamc_DoWork(ByVal sender As System.Object, ByVal e As ComponentModel.DoWorkEventArgs) Handles amcworker.DoWork
Dim URI As String = host & Remotefileamc
Dim FTP As System.Net.FtpWebRequest = CType(System.Net.FtpWebRequest.Create(URI), System.Net.FtpWebRequest)
'Set the credentials
FTP.Credentials = New System.Net.NetworkCredential(username, password)
'FTP Options
FTP.KeepAlive = False
FTP.UseBinary = True
'Define the action as Download
FTP.Method = System.Net.WebRequestMethods.Ftp.DownloadFile
'Get the response to the Ftp request and the associated stream
Try
Dim response As System.Net.FtpWebResponse = CType(FTP.GetResponse, System.Net.FtpWebResponse)
Dim Length As Long = response.ContentLength
Dim StopWatch As New Stopwatch
Dim CurrentSpeed As Double = Nothing
Using responseStream As IO.Stream = response.GetResponseStream
'loop to read & write to file
Using fs As New IO.FileStream(localfileamc, IO.FileMode.Create)
Dim buffer(2047) As Byte
Dim read As Integer = 0
Dim count As Integer
Do
If amcworker.CancellationPending = True Then
e.Cancel = True
Return
End If
StopWatch.Start()
amcworker.ReportProgress(CShort(count / Length * 100 + 0.5))
read = responseStream.Read(buffer, 0, buffer.Length)
fs.Write(buffer, 0, read)
count += read
Loop Until read = 0
StopWatch.Stop()
responseStream.Close()
fs.Flush()
fs.Close()
End Using
responseStream.Close()
End Using
response.Close()
Catch ex As Exception
MessageBox.Show("An error has occurred during the process:" & vbCrLf & vbCrLf & ex.Message & vbCrLf & vbCrLf & "Please close the application and try again." _
& vbCrLf & "If you continue to encounter this error please Email")
myProcessamc_Exited()
End Try
Installamc()
End Sub
'Starts the installation
Sub Installamc()
startamc.StartInfo.FileName = "C:\AMC.exe"
startamc.EnableRaisingEvents = True
Try
startamc.Start()
Catch ex As Exception
MsgBox(ex.Message)
End Try
Dispatcher.Invoke(New Action(AddressOf Progressamc_Hide))
End Sub
'Hide Dialog during install
Private Sub Progressamc_Hide()
progressamc.Hide()
End Sub
'Report progress
Private Sub amcworker_ProgressChanged(ByVal sender As System.Object, ByVal e As ComponentModel.ProgressChangedEventArgs) Handles amcworker.ProgressChanged
ProgressBarAMC.value = e.ProgressPercentage
blprgrsAMC.Content = "Downloading: " & e.ProgressPercentage & "%"
End Sub
End Class
Again, any help would be greatly appreciated.
Edit: I've made the following edit to the code but I'm not entirely sure it's doing what I think it's doing. Basically what I intended is for the ReportProgress to only run once every 2047 bytes read.
'Get the response to the Ftp request and the associated stream
Try
Dim response As System.Net.FtpWebResponse = CType(FTP.GetResponse, System.Net.FtpWebResponse)
Dim Length As Long = response.ContentLength
Dim StopWatch As New Stopwatch
Dim CurrentSpeed As Double = Nothing
Using responseStream As IO.Stream = response.GetResponseStream
'loop to read & write to file
Using fs As New IO.FileStream(localfileamc, IO.FileMode.Create)
Dim buffer(2047) As Byte
Dim read As Integer = 0
Dim count As Integer
Dim chunk As Integer = Int(2047 / Length)
Dim cycle As Integer = chunk = count
Do
If amcworker.CancellationPending = True Then
e.Cancel = True
Return
End If
StopWatch.Start()
If cycle = True Then
amcworker.ReportProgress(CShort(count / Length * 100 + 0.5))
Else
End
End If
read = responseStream.Read(buffer, 0, buffer.Length)
fs.Write(buffer, 0, read)
count += read
Loop Until read = 0
StopWatch.Stop()
responseStream.Close()
fs.Flush()
fs.Close()
End Using
responseStream.Close()
End Using
response.Close()
Catch ex As Exception
MessageBox.Show("An error has occurred during the process:" & vbCrLf & vbCrLf & ex.Message & vbCrLf & vbCrLf & "Please close the application and try again." _
& vbCrLf & "If you continue to encounter this error please Email")
myProcessamc_Exited()
End Try
I didn't scrutinize the code carefully, but I don't see why you're using stopwatch, so I took out the references. I'm not sure what starting it multiple times inside the loop and ending it outside would do anyway.
The use of the word END in the second example will comletely end your app! Pretty sure that's what you want there.
Try this modification of your first code. The key is only updating if change is >= 5%:
Using fs As New IO.FileStream(localfileamc, IO.FileMode.Create)
Dim buffer(2047) As Byte
Dim read As Integer = 0
Dim count As Integer
dim LastPct as Short = -5
dim Pct as Short = 0
Do
If amcworker.CancellationPending = True Then
e.Cancel = True
Return
End If
Pct = CShort(count / Length * 100 + 0.5)
if Pct>= (LastPct + 5)
amcworker.ReportProgress(Pct)
LastPCT= Pct
EndIf
read = responseStream.Read(buffer, 0, buffer.Length)
fs.Write(buffer, 0, read)
count += read
Loop Until read = 0
amcworker.ReportProgress(100)
responseStream.Close()
fs.Flush()
fs.Close()
End Using