Protected Sub dgResult_ItemCommand(ByVal source As System.Object, ByVal e As System.Web.UI.WebControls.DataGridCommandEventArgs) Handles dgResult.ItemCommand
If strErr = "" Then
Dim ddl As DropDownList = CType(e.Item.FindControl("ddlClassificationType"), DropDownList)
Dim defaultValue As Boolean = ddl.SelectedItem.Text.Contains("*")
Dim originalValue As String = String.Empty
If defaultValue = False Then
'update AppDetail
strErr = appDetailDBA.UpdateAppDetail(appCode, subCode, ddl.SelectedValue, Today.Date)
End If
If strErr = "" Then
lblError.Text = msgClass.successMsg(subCodeName, "1")
Else
lblError.Text = msgClass.ErrorMsg(subCodeName, "1")
End If
dgResult.DataSource = appDetailDBA.getDataClassification(empID, txtSearch.Text)
dgResult.DataBind()
End Sub
Function UpdateAppDetail(ByVal appCode As String, ByVal subCode As String, ByVal classType As String, ByVal classEffDte As String)
Dim strErr As String = ""
Dim con As New SqlConnection(kiosk_loginConnStr)
con.Open()
Try
Dim sqlCommand As SqlCommand = con.CreateCommand()
Dim sql As String = "Update AppDetail SET ClassificationType = '" + classType + "', ClassificationEffDate = '" + classEffDte + "' WHERE AppCode = '" + appCode + "'" & _
" AND SubCode = '" + subCode + "'"
sqlCommand.CommandText = sql
sqlCommand.ExecuteNonQuery()
Catch ex As Exception
strErr = ex.Message
Finally
con.Close()
End Try
Return strErr
End Function
What type of database are you using? Do you commit the changes to the database?
[Update (from discussion below)] It appears that VB automatically commits all commands unless you explicitly tell it not to, so that's not the problem.
[Update 2] My working theory is that the database is configured incorrectly, as in ExecuteNonQuery() Not Working
Another possibly explaination could be this: http://social.msdn.microsoft.com/Forums/en-US/vblanguage/thread/dbbf8025-9f53-4862-8705-62a106fe2114
My suggestion would be to try running sqlCommand.Commit(), this "should" stash any changes you have made on the database, into the actual database. Please note, my actual "command" might be off, but the idea is there. If you can commit on the sql command, try committing on the connection level.
Related
I have tried to convert one of my Visual Basic 6 programs to Visual Basic.NET. This program basically crawls email and mobile number data from a web page link. This program works great in Visual Basic 6 but after converting to Visual Basic.NET is not providing any function or result in .NET.
Imports VBScript_RegExp_55
Imports System.Collections.Specialized
Imports System.Diagnostics
Public Class autoextratorform
Dim emailsearch As New ListViewItem()
Dim numbersearch As New ListViewItem
Private Declare Function SendMessageByString _
Lib "user32" _
Alias "SendMessageA" _
(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As String) _
As Long
Private Const LB_SELECTSTRING = &H18C
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private WithEvents cIE As InternetHtml
Private WithEvents cExtLinks As cExtractLinks
Private cGSearch As cGoogleSearch
Dim Excel As Object
Dim Excelsheet As Object
Dim a() As String
Dim b() As String
Dim c() As String
Dim i As Integer
' Needs reference to Microsoft VBscript Regular Expressions I recomend ver 5.5.
'
Dim baseurl As String ' var to store base url so we can build the full path
Dim dVisited ' Dictionary to hold visited urls = I think Missing here
Dim dEmail ' dictionary to hold emails = I think Missing here
Dim dnumber ' = I think Missing here
Dim dweb '= I think Missing here
' We are putting the emails in a list also, for user feed back
'It would be less momery intensive and faster to just keep these in the dictionry object
'which allows to easily tell if the email already exist
Dim regxPage ' var to hold regular expression to extract urls
Dim regxEmail ' var to hold regular expression to extract emails
Dim regnumber
Dim regweb
Dim Match, Matches As String ' we use these to store are regx matches
Dim Match1, Matches1 As String
Dim Match2, Matches2 As String
' Regular expressions are super powerfull and have been a part of unix for a long time
' goto the form load event to see the regex initialization
' to learn more about regular expressions and to download the latest scripting runtime see
' http://msdn.microsoft.com/scripting/default.htm?/scripting/vbscript/techinfo/vbsdocs.htm
Dim email, pageurl, mnumber, sweb As String
' The above is only because dictionary.exist does not work directly on Match var
Dim stopcrawl As Integer ' Used to exit crawl loop
Private Sub ComboBox1_SelectedIndexChanged(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles ComboBox1.SelectedIndexChanged
Select Case ComboBox1.SelectedIndex
Case 0
ListBox2.Items.Clear()
ListBox2.Items.Add("http://classads.jang.com.pk/default.asp?cityid=1")
ListBox2.Items.Add("http://www.merapakistan.com/classifieds/")
ListBox2.Items.Add("http://olx.com.pk/")
ListBox2.SelectedIndex = 0
txtStartUrl.Text = ListBox2.Text
Case 1
ListBox2.Items.Clear()
ListBox2.Items.Add("http://www.locanto.com.pk/")
ListBox2.Items.Add("http://pakistanclassifiedads.com/")
ListBox2.Items.Add("http://pkr.com.pk/")
txtStartUrl.Text = ListBox2.Text
Case 2
ListBox2.Items.Clear()
ListBox2.Items.Add("http://adpost.pk/")
ListBox2.Items.Add("http://page.com.pk/")
ListBox2.Items.Add("http://www.clasf.pk/")
ListBox2.SelectedIndex = 0
txtStartUrl.Text = ListBox2.Text
Case 3
ListBox2.Items.Clear()
ListBox2.Items.Add("http://www.nelaam.com/")
ListBox2.Items.Add("http://www.asani.com.pk/")
ListBox2.Items.Add("http://freepost.com.pk/")
ListBox2.SelectedIndex = 0
txtStartUrl.Text = ListBox2.Text
End Select
End Sub
Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Command1.Click
stopcrawl = 0 ' set stop crawl so we do not exit loop
If txtStartUrl.Text & "" = "" Then
lblresult.Text = ("Please Load your Desired Site List !")
Exit Sub
ElseIf txtStartUrl.Text & "" = "http://" Then
lblresult.Text = ("Please Load your Desired Site List !")
Exit Sub
ElseIf txtStartUrl.Text = "" Then
lblresult.Text = ("Please Load your Desired Site List !")
Exit Sub
End If
' the above should really check for a valid url, but I am a lazy PERL programmer
ListBox1.Items.Add(txtStartUrl.Text) 'add item to list
Label16.Text = (ListBox2.Items.Count - 1)
Label8.Text = (ListBox2.Items.Count)
lblresult.Text = " Start service for searching Email address and Mobile Numbers"
Command1.Enabled = False
ComboBox1.Enabled = False
LaVolpeButton4.Enabled = True
'UPGRADE_ISSUE: (2064) ComboBox property Combo1.Locked was not upgraded. More Information: https://docs.mobilize.net/vbuc/ewis#2064
LaVolpeButton8.Enabled = False
LaVolpeButton9.Enabled = False
txtStartUrl.ReadOnly = True
crawl() ' and were off
End Sub
Private Sub autoextrator_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
With listnumber
.Columns.Clear()
.Columns.Add("Count!", CInt(Width * 0.1))
.Columns.Add("Mobile Number!", CInt(Width * 0.2))
.Columns.Add("Web URL!", CInt(Width * 0.68))
End With
With listemail
.Columns.Clear()
.Columns.Add("Count!", CInt(Width * 0.1))
.Columns.Add("Email Address!", CInt(Width * 0.2))
.Columns.Add("Web URL!", CInt(Width * 0.68))
End With
'initialize dictionary and regx objects
dVisited = CreateObject("Scripting.Dictionary")
dVisited.CompareMode = CompareMethod.Binary
dEmail = CreateObject("Scripting.Dictionary")
dEmail.CompareMode = CompareMethod.Binary
dnumber = CreateObject("Scripting.Dictionary")
dnumber.CompareMode = CompareMethod.Binary
dweb = CreateObject("Scripting.Dictionary")
dweb.CompareMode = CompareMethod.Binary
Dim counting1 As String
Dim counting2 As String
regxPage = New VBScript_RegExp_55.RegExp() ' Create a regular expression.
regxPage.Pattern = "HREF=""[^""#]+[.][^""#]+" ' Set pattern."
regxPage.IgnoreCase = True ' Set case insensitivity.
regxPage.Global = True ' Set global applicability.
regxEmail = New VBScript_RegExp_55.RegExp() ' Create a regular expression.
regxEmail.Pattern = "\b[a-z0-9._%+-]+#[a-z0-9.-]+\.[a-z]{2,4}\b" ' Set pattern."
regxEmail.IgnoreCase = True ' Set case insensitivity.
regxEmail.Global = True ' Set global applicability.
regnumber = New VBScript_RegExp_55.RegExp()
counting1 = "(\+92)-?\d{3}-?\d{7}"
counting2 = "(?:0092|0|\+92)-?\d{3}-?\d{7}"
regnumber.Pattern = counting1
regnumber.Pattern = counting2
regnumber.IgnoreCase = True
regnumber.Global = True
cIE = New InternetHtml()
cGSearch = New cGoogleSearch()
cExtLinks = New cExtractLinks()
End Sub
Sub crawl()
While ListBox1.Items.Count > 0 ' loop while list has data
If stopcrawl = 1 Then GoTo exitcrawl
getpage(ListBox1.Items(0)) ' This is the heart of the prog, except for the regx = I think Missing here
' stuff in the form load event
ListBox1.Items.Remove(0) ' remove item from list
End While
ListBox2.Items.Remove(ListBox2.SelectedIndex)
If ListBox2.SelectedIndex < ListBox2.Items.Count - 1 Then
ListBox2.SelectedIndex += 1
txtStartUrl.Text = ListBox2.Items.ToString
exitcrawl:
If ListBox2.Items.Count = 0 Then
MessageBox.Show("Searching has completed !", "Done ! searching", MessageBoxButtons.OK, MessageBoxIcon.Information)
txtStartUrl.ReadOnly = False
txtStartUrl.Text = ""
Label3.Text = "-----------------------------------------------------------"
LaVolpeButton4.Enabled = False
Command1.Enabled = True
LaVolpeButton8.Enabled = True
LaVolpeButton9.Enabled = True
End If
End If
End Sub
Sub getpage(ByVal page As String)
On Error Resume Next
If dVisited.Contains(page) Then
Exit Sub
Else
dVisited.Add(page, 1) ' add page to dVisited dictionary
Label6.Text = CStr(ListBox1.Items.Count)
Label14.Text = CStr(dVisited.Count)
Label3.Text = page
End If
baseurl = getpath(page) ' build full url - see getpath
TextBox1.Text = ""
If ListBox1.Items.Count > 5000 Then Exit Sub ' sets the maximum cache (so we don't run out of mem)
Using wc As New System.Net.WebClient
TextBox1.Text = wc.DownloadString(page)
End Using
Matches = regxPage.Execute(TextBox1.Text) ' Execute search.
For Each Me.Match In Matches
pageurl = Match
If InStr(1, pageurl, "http://", vbTextCompare) Then
If dVisited.Exists(pageurl) = False Then ListBox1.Items.Add(Mid(pageurl, 7))
Else
If dVisited.Exists(baseurl & Mid(pageurl, 7)) = False Then ListBox1.Items.Add(baseurl & Mid(pageurl, 7))
End If
Next
' search for email
Matches = regxEmail.Execute(TextBox1.Text) ' Execute search.
For Each Me.Match In Matches ' Iterate Matches collection.
' check if email exist
email = Match
Debug.Print(email & dEmail.Exists(email))
If dEmail.Exists(email) = False Then
dEmail.Add((email), 1)
Dim d As Integer
d = listemail.Items.Count
d = d + 1
emailsearch = listemail.Items.Add(d)
emailsearch.SubItems.Add(email.ToString)
emailsearch.SubItems.Add(pageurl.ToString)
ListBox3.Items.Add(email)
Label10.Text = listemail.Items.Count
End If
Next
Matches1 = regnumber.Execute(TextBox1.Text)
For Each Me.Match1 In Matches1
mnumber = Match1
Debug.Print(mnumber & dnumber.Exists(mnumber))
If dnumber.Exists(mnumber) = False Then
dnumber.Add((mnumber), 1)
Dim c As Integer
c = listnumber.Items.Count
c = c + 1
numbersearch = listnumber.Items.Add(c)
numbersearch.SubItems.Add(mnumber.ToString)
numbersearch.SubItems.Add(pageurl.ToString)
Label12.Text = listnumber.Items.Count
End If
Next
End Sub
Function getpath(ByVal URL As String) As String
' look for the last / and get a string up to that location
Dim lastbar As Integer = URL.LastIndexOf("/") + 1
Dim tmppath As String = URL.Substring(0, Math.Min(lastbar, URL.Length))
If tmppath = "http://" Then tmppath = URL ' full path already so return url
Return tmppath
End Function
Public Function StripOut(ByVal From As String, ByVal What As String) As String
Dim result As String = ""
result = From
For i As Integer = 1 To Strings.Len(What)
result = result.Replace(What.Substring(i - 1, Math.Min(1, What.Length - (i - 1))), "")
Next i
Return result
End Function
Private Sub LaVolpeButton4_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles LaVolpeButton4.Click
stopcrawl = 1
MsgBox(" Service has Stoped by USER !")
LaVolpeButton4.Enabled = False
Command1.Enabled = True
End Sub
Private Sub LaVolpeButton8_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles LaVolpeButton8.Click
Dim strData As String = ""
Dim strQ() As String
Dim intFile As Integer
' Set up the Common Dialog initial Directory
' to the application path. Filter for Text and All files
' Prompt the user to select a file
'
cmd.InitialDirectory = My.Application.Info.DirectoryPath
cmd.Filter = "Text Files(*.txt)|*.txt|All Files(*.*)|*.*"
cmd.Title = "Select Email Addresses File"
cmd.ShowDialog()
If cmd.FileName <> "" Then
'
' If the user selected a file
' open and read the entire contents
' then split it into records
'
intFile = FileSystem.FreeFile()
FileSystem.FileOpen(intFile, cmd.FileName, OpenMode.Input)
strData = FileSystem.InputString(intFile, FileSystem.LOF(intFile))
FileSystem.FileClose(intFile)
strQ = strData.Split(CChar(Environment.NewLine))
'
' Populate the texbox array with the questions
' (either the number of textboxes in the control array or
' number of questions, which ever is the smaller)
For Each strQ_item As String In strQ
ListBox2.Items.Add(strQ_item)
Next strQ_item
txtStartUrl.Text = ListBox2.Text
End If
End Sub
End Class
2- This is Visual basic 6 Code that works perfect.
Dim baseurl As String ' var to store base url so we can build the full path
Dim dVisited As Dictionary ' Dictionary to hold visited urls
Dim dEmail As Dictionary ' dictionary to hold emails
Dim dnumber As Dictionary
Dim dweb As Dictionary
Sub crawl()
While List1.ListCount > 0 ' loop while list has data
If stopcrawl = 1 Then GoTo exitcrawl
getpage List1.List(0) ' This is the heart of the prog, except for the regx
' stuff in the form load event
List1.RemoveItem (0) ' remove item from list
Wend
List2.RemoveItem (List2.ListIndex)
If List2.ListIndex < List2.ListCount - 1 Then
List2.ListIndex = List2.ListIndex + 1
txtStartUrl = List2.Text
Command1_Click
Else
exitcrawl:
If List2.ListCount = 0 Then
MsgBox "Searching has completed !", vbInformation, "Done ! searching"
WebBrowser1.Stop
txtStartUrl.Locked = False
txtStartUrl.Text = ""
Label3.Caption = "-----------------------------------------------------------"
LaVolpeButton4.Enabled = False
Command1.Enabled = True
LaVolpeButton8.Enabled = True
LaVolpeButton9.Enabled = True
End If
End If
End Sub
This is not code I wrote completely, some I have pieced together from one or two sites and some is what I have set. What I'm trying to do is use a regex function defined in regex.Pattern to look at message subject and extract a value. This is what I'm going to see in the email subject:
New Linux Server: prod-servername-a001
So far I can get the full message subject into the Excel file, but when I have tried to implement the regex portion, I get an error code 5017 (error in expression from what I can find) and the regex is not "working". My expectation is the script will pull the message subject, use the regex to extract the value and place it in the cell. I'm using RegEx Builder (regex testing program) to test the expression and it works there, but not here. I am very new to VB, so I don't know if the issue is that VB can't use this expression or if the script is failing somewhere else and the error is something residual from another problem. Or is there a better way to write this?
Sub ExportToExcel()
On Error GoTo ErrHandler
'Declarations
Dim appExcel As Excel.Application
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim rng As Excel.Range
Dim strSheet As String
Dim filePath As String
Dim strPath As String
Dim intRowCounter As Integer
Dim intColumnCounter As Integer
Dim msg As Outlook.MailItem
Dim nms As Outlook.NameSpace
Dim fld As Outlook.MAPIFolder
Dim itm As Object
'RegEx Declarations
Dim result As String
Dim allMatches As Object
Dim regex As Object
Set regex = CreateObject("vbscript.regexp")
regex.Pattern = "(?<=Server: ).*"
regex.Global = True
regex.IgnoreCase = True
' Set the filename and path for output, requires creating the path to work
strSheet = "outlook.xlsx"
strPath = "D:\temp\"
filePath = strPath & strSheet
'Debug
Debug.Print filePath
'Select export folder
Set nms = Application.GetNamespace("MAPI")
Set fld = nms.PickFolder
'Handle potential errors with Select Folder dialog box.
If fld Is Nothing Then
MsgBox "There are no mail messages to export", vbOKOnly, "Error"
Exit Sub
ElseIf fld.DefaultItemType <> olMailItem Then
MsgBox "There are no mail messages to export", vbOKOnly, "Error"
Exit Sub
ElseIf fld.Items.Count = 0 Then
MsgBox "There are no mail messages to export", vbOKOnly, "Error"
Exit Sub
End If
'Open and activate Excel workbook.
Set appExcel = CreateObject("Excel.Application")
appExcel.Workbooks.Open (filePath)
Set wkb = appExcel.ActiveWorkbook
Set wks = wkb.Sheets(1)
wks.Activate
appExcel.Application.Visible = True
'Copy field items in mail folder.
For Each itm In fld.Items
intColumnCounter = 1
Set msg = itm
If itm.UnRead = True Then
intRowCounter = intRowCounter + 1
wks.Cells(1, 1).value = "Subject" 'Row 1 Column 1 (A)
wks.Cells(1, 2).value = "Unread" 'Row 1 Column 2 (B)
wks.Cells(1, 3).value = "Server" 'Row 1 Column 3 (C)
Set rng = wks.Cells(intRowCounter + 1, intColumnCounter)
If InStr(msg.Subject, "Server:") Then
Set allMatches = regex.Execute(msg.Subject)
rng.value = allMatches
intColumnCounter = intColumnCounter + 1
msg.UnRead = False
Else
rng.value = msg.Subject
intColumnCounter = intColumnCounter + 1
msg.UnRead = False
End If
Set rng = wks.Cells(intRowCounter + 1, intColumnCounter)
rng.value = msg.UnRead
intColumnCounter = intColumnCounter + 1
End If
Next itm
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing
Exit Sub
ErrHandler:
If Err.Number = 1004 Then
MsgBox filePath & " doesn't exist", vbOKOnly, "Error"
ElseIf Err.Number = 13 Then
MsgBox Err.Number & ": Type Mismatch", vbOKOnly, "Error"
ElseIf Err.Number = 438 Then
MsgBox Err.Number & ": Object doesn't support this property or method", vbOKOnly, "Error"
ElseIf Err.Number = 5017 Then
MsgBox Err.Number & ": Error in expression", vbOKOnly, "Error"
Else
MsgBox Err.Number & ": Description: ", vbOKOnly, "Error"
End If
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing
End Sub
VBA regex does not support lookbehinds, but in this case, you do not need a positive lookbehind, you just can use a capturing group - "Server: (.*)"` - and then access Group 1 value:
Set regex = CreateObject("vbscript.regexp")
regex.Pattern = "Server: (.*)"
regex.IgnoreCase = True
Set allMatches = regex.Execute("New Linux Server: prod-servername-a001")
If allMatches.Count <> 0 Then
rng.Value = allMatches(0).Submatches(0)
End If
Here,
Server: - matches a string Server: + space
(.*) - matches and captures into Group 1 zero or more characters other than a newline up to the end of line.
See more about capturing groups.
This is not code I wrote completely, some I have pieced together from one or two sites and some is what I have set. What I'm trying to do is use a regex function defined in regex.Pattern to look at message subject and extract a value. This is what I'm going to see in the email subject:
New Linux Server: prod-servername-a001
So far I can get the full message subject into the Excel file, but when I have tried to implement the regex portion, I get an error code 5017 (error in expression from what I can find) and the regex is not "working". My expectation is the script will pull the message subject, use the regex to extract the value and place it in the cell. I'm using RegEx Builder (regex testing program) to test the expression and it works there, but not here. I am very new to VB, so I don't know if the issue is that VB can't use this expression or if the script is failing somewhere else and the error is something residual from another problem. Or is there a better way to write this?
Sub ExportToExcel()
On Error GoTo ErrHandler
'Declarations
Dim appExcel As Excel.Application
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim rng As Excel.Range
Dim strSheet As String
Dim filePath As String
Dim strPath As String
Dim intRowCounter As Integer
Dim intColumnCounter As Integer
Dim msg As Outlook.MailItem
Dim nms As Outlook.NameSpace
Dim fld As Outlook.MAPIFolder
Dim itm As Object
'RegEx Declarations
Dim result As String
Dim allMatches As Object
Dim regex As Object
Set regex = CreateObject("vbscript.regexp")
regex.Pattern = "(?<=Server: ).*"
regex.Global = True
regex.IgnoreCase = True
' Set the filename and path for output, requires creating the path to work
strSheet = "outlook.xlsx"
strPath = "D:\temp\"
filePath = strPath & strSheet
'Debug
Debug.Print filePath
'Select export folder
Set nms = Application.GetNamespace("MAPI")
Set fld = nms.PickFolder
'Handle potential errors with Select Folder dialog box.
If fld Is Nothing Then
MsgBox "There are no mail messages to export", vbOKOnly, "Error"
Exit Sub
ElseIf fld.DefaultItemType <> olMailItem Then
MsgBox "There are no mail messages to export", vbOKOnly, "Error"
Exit Sub
ElseIf fld.Items.Count = 0 Then
MsgBox "There are no mail messages to export", vbOKOnly, "Error"
Exit Sub
End If
'Open and activate Excel workbook.
Set appExcel = CreateObject("Excel.Application")
appExcel.Workbooks.Open (filePath)
Set wkb = appExcel.ActiveWorkbook
Set wks = wkb.Sheets(1)
wks.Activate
appExcel.Application.Visible = True
'Copy field items in mail folder.
For Each itm In fld.Items
intColumnCounter = 1
Set msg = itm
If itm.UnRead = True Then
intRowCounter = intRowCounter + 1
wks.Cells(1, 1).value = "Subject" 'Row 1 Column 1 (A)
wks.Cells(1, 2).value = "Unread" 'Row 1 Column 2 (B)
wks.Cells(1, 3).value = "Server" 'Row 1 Column 3 (C)
Set rng = wks.Cells(intRowCounter + 1, intColumnCounter)
If InStr(msg.Subject, "Server:") Then
Set allMatches = regex.Execute(msg.Subject)
rng.value = allMatches
intColumnCounter = intColumnCounter + 1
msg.UnRead = False
Else
rng.value = msg.Subject
intColumnCounter = intColumnCounter + 1
msg.UnRead = False
End If
Set rng = wks.Cells(intRowCounter + 1, intColumnCounter)
rng.value = msg.UnRead
intColumnCounter = intColumnCounter + 1
End If
Next itm
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing
Exit Sub
ErrHandler:
If Err.Number = 1004 Then
MsgBox filePath & " doesn't exist", vbOKOnly, "Error"
ElseIf Err.Number = 13 Then
MsgBox Err.Number & ": Type Mismatch", vbOKOnly, "Error"
ElseIf Err.Number = 438 Then
MsgBox Err.Number & ": Object doesn't support this property or method", vbOKOnly, "Error"
ElseIf Err.Number = 5017 Then
MsgBox Err.Number & ": Error in expression", vbOKOnly, "Error"
Else
MsgBox Err.Number & ": Description: ", vbOKOnly, "Error"
End If
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing
End Sub
VBA regex does not support lookbehinds, but in this case, you do not need a positive lookbehind, you just can use a capturing group - "Server: (.*)"` - and then access Group 1 value:
Set regex = CreateObject("vbscript.regexp")
regex.Pattern = "Server: (.*)"
regex.IgnoreCase = True
Set allMatches = regex.Execute("New Linux Server: prod-servername-a001")
If allMatches.Count <> 0 Then
rng.Value = allMatches(0).Submatches(0)
End If
Here,
Server: - matches a string Server: + space
(.*) - matches and captures into Group 1 zero or more characters other than a newline up to the end of line.
See more about capturing groups.
Looking for some help with my macro that loops through subfolders and brings back data from the workbooks that match my filename pattern, because the name changes each month.
It works seamlessly if the pattern is "[0-9][0-9][0-9][0-9][0-9][0-9] Filename"
But fails if "[0-9][0-9][0-9][0-9]_[0-9][0-9] Filename"
Any ideas on how to handle the underscore please?
This fails "[0-9][0-9][0-9][0-9][_][0-9][0-9] Filename"
Thanks heaps
GWS
Option Explicit
Option Base 1
Private Const PORTFOLIO_CODE As String = "G030"
Private Sub ExtractData()
' get workbook list
Dim wbList As Collection
Set wbList = New Collection
Application.DisplayAlerts = False
RecursiveFileSearch _
"O:\Sales and Marketing\Monthly Reports\", _
"[0-9][0-9][0-9][0-9][_][0-9][0-9] Monthly Report.xlsm", _ 'fails to find any workbooks
'"[0-9][0-9][0-9][0-9][0-9][0-9] Monthly Report.xlsm", _ 'would work except my file names contain underscores
wbList
Dim resultOffset As Integer
wsResult.Name = result
resultOffset = 1
Dim wbName As Variant, wbOpen As Workbook, wsFund As Worksheet
For Each wbName In wbList
' loop through workbook list
' - open workbook, hidden
Application.ScreenUpdating = False
Set wbOpen = Workbooks.Open(Filename:=wbName, ReadOnly:=True)
wbOpen.Windows(1).Visible = False
' - get worksheet for fund
Set wsFund = wbOpen.Worksheets(PORTFOLIO_CODE)
Application.ScreenUpdating = True
' - find top of data
Dim valueDate As Date
valueDate = WorksheetFunction.EoMonth(DateSerial(2000 + CInt(Left(wbOpen.Name, 2)), CInt(Mid(wbOpen.Name, 3, 2)), 1), 0)
Debug.Print valueDate, wbOpen.Name
ThisWorkbook.Worksheets(PORTFOLIO_CODE).Activate
Dim baseData As Excel.Range
Set baseData = wsFund.Range("AQ:AQ").Find("Currency")
If Not baseData Is Nothing Then
' - loop through data
Dim rowOffset As Integer
rowOffset = 0
wsResult.Range("A1").Offset(resultOffset, 0).Value = valueDate ' baseData.Offset(rowOffset, 0).Value
wsResult.Range("A1").Offset(resultOffset, 1).Value = baseData.Offset(rowOffset, 0).Value
wsResult.Range("A1").Offset(resultOffset, 2).Value = baseData.Offset(rowOffset, 5).Value
resultOffset = resultOffset + 1
End If
' - close workbook
wbOpen.Close SaveChanges:=False
DoEvents
Next
Application.DisplayAlerts = True
End Sub
RecursiveFileSearch
Sub RecursiveFileSearch( _
ByVal targetFolder As String, _
ByRef filePattern As String, _
ByRef matchedFiles As Collection _
)
Dim oRegExp As New VBScript_RegExp_55.RegExp
oRegExp.Global = False
oRegExp.IgnoreCase = True
oRegExp.MultiLine = False
oRegExp.Pattern = filePattern
Dim oFSO As Scripting.FileSystemObject
Set oFSO = New Scripting.FileSystemObject
'Get the folder oect associated with the target directory
Dim oFolder As Variant
Set oFolder = oFSO.GetFolder(targetFolder)
'Loop through the files current folder
Dim oFile As Variant
For Each oFile In oFolder.Files
If oRegExp.test(oFile.Name) Then
matchedFiles.Add oFile
End If
Next
'Loop through the each of the sub folders recursively
Dim oSubFolders As Object
Set oSubFolders = oFolder.Subfolders
Dim oSubfolder As Variant
For Each oSubfolder In oSubFolders
RecursiveFileSearch oSubfolder, filePattern, matchedFiles
Next
'Garbage Collection
Set oFolder = Nothing
Set oFile = Nothing
Set oSubFolders = Nothing
Set oSubfolder = Nothing
Set oFSO = Nothing
Set oRegExp = Nothing
End Sub
Perhaps:
\d{4}_\d{2}.*Monthly Report\.xlsm
My code was escaping the () and . to override the defined regex behavior. Portland Runner suggestion solved the question. ^[0-9]{3,4}[_][0-9]{2} SAMPSON International Shares Passive (Hedged) Trust Mandate Monthly Report.xlsm
I'm creating an application that will be able to tell me who is logged onto what PC, in the manufacturing center, where I work.
I'm using psexec's psloggedon cmd process to get me the information for me and a VB.net windows application to show me the information.
I begin by first querying a databse for all the PC's we currently have active and dumping the data into a datagridview object. (Shown below)
Private Sub Button(sender As System.Object, e As System.EventArgs) Handles btngetPC.Click
'GET AREAS FROM DATABASE
Dim ds As New DataSet()
Dim db As String = "QUERY STRING GOES HERE"
'CONNECT TO DATABASE
Using da As New SqlDataAdapter(db, MySQLConnection)
da.Fill(ds, "MACHINE_NAME")
End Using
With datagridView1
.DataSource = ds.Tables("MACHINE_NAME")
End With
'ADD COLUMN TO DATAGRIDVIEW
datagridView1.Columns.Add("LOGGED_IN", "LOGGED_IN")
MySQLConnection.Close()
End Sub
Once I have my datagridview object filled out with all my active PC's, I can then use the machine names to run the psloggedon cmd to get who is logged in. I do so by using:
Private Sub execute(sender As Object, e As EventArgs) Handles bntExecuteCmd.Click
'COUNT ENTRIES
Dim RowCount As Integer = datagridView1.RowCount
''EXECUTE CMD
For i = 0 To RowCount - 2
'PERFORM PSLOGGEDON ROUTINE
Dim Proc1 As New Process
Proc1.StartInfo = New ProcessStartInfo("psloggedon")
Proc1.StartInfo.Arguments = "-l \\" & datagridView1.Rows(i).Cells(1).Value & ""
Proc1.StartInfo.RedirectStandardOutput = True
Proc1.StartInfo.UseShellExecute = False
Proc1.StartInfo.CreateNoWindow = True
Proc1.Start()
If Not Proc1.WaitForExit(300) Then
Proc1.Kill()
End If
'INSERT RESULTS INTO LOGGEN_IN COLUMN
Dim msg As String = Proc1.StandardOutput.ReadToEnd
Dim idx As Integer = msg.LastIndexOf("\"c)
Dim user As String = msg.Substring(idx + 1)
Dim final As String = UCase(System.Text.RegularExpressions.Regex.Replace(user, "^ELP.*$", ""))
datagridView1.Rows(i).Cells(2).Value = final
Next
End Sub
Finally, here is my question:
To get the employee names I must use regex becuase the raw format is unacceptable.
raw format:
"Connecting to Registry of \ELPSC171698...
Users logged on locally:
ECHOSTAR\Jane.Doe"
format after applying:
'INSERT RESULTS INTO LOGGEN_IN COLUMN
Dim msg As String = Proc1.StandardOutput.ReadToEnd
Dim idx As Integer = msg.LastIndexOf("\"c)
Dim user As String = msg.Substring(idx + 1)
Dim final As String = UCase(System.Text.RegularExpressions.Regex.Replace(user, "^ELP.*$", ""))
datagridView1.Rows(i).Cells(2).Value = final
"PAULA.RODRIGUEZ"
Looks good, right? However, when the raw format has more than one associate, like so:
"Connecting to Registry of \ELPSC173068...
Users logged on locally:
ECHOSTAR\John.Doe
ECHOSTAR\Ben.Doe"
the code I have written will get me the last person in this list. In this case, I will get JOHN.DOE when I need to get BEN.DOE.
Now the question: How can I change this code:
'INSERT RESULTS INTO LOGGEN_IN COLUMN
Dim msg As String = Proc1.StandardOutput.ReadToEnd
Dim idx As Integer = msg.LastIndexOf("\"c)
Dim user As String = msg.Substring(idx + 1)
Dim final As String = UCase(System.Text.RegularExpressions.Regex.Replace(user, "^ELP.*$", ""))
datagridView1.Rows(i).Cells(2).Value = final
To get me the first person, "JOHN.DOE" from here:
"Connecting to Registry of \ELPSC173068...
Users logged on locally:
ECHOSTAR\John.Doe
ECHOSTAR\Ben.Doe"
I hope my question was clear and well constructed. Thank you.
Use more specific regex and a capture group to get multiple items.
Dim mc As MatchCollection = Regex.Matches("Users logged on locally: ECHOSTAR\John.Doe ECHOSTAR\Ben.Doe", "[\t ]+[a-z_0-9]+\\(?<n>[a-z_\.0-9]+)(([\t ])|($))", RegexOptions.ExplicitCapture Or RegexOptions.IgnoreCase Or RegexOptions.Multiline)
For Each m As Match In mc
Dim name As String = m.Groups("n").value
Next
if you just want the first one then...
If mc.Count >= 1 Then
Dim name As String = mc(0).Groups("n").Value
End If
Change
Dim idx As Integer = msg.LastIndexOf("\"c)
to
Dim idx As Integer = msg.IndexOf("\"c)
Alternatively consider this:
Assuming you've validated the string first.
Dim user As String = msg.Split({"\"c, " "c}, StringSplitOptions.RemoveEmptyEntries)(1) _
.Replace("."c, " "c).ToUpper
To leave the decimal in just remove .Replace("."c, " "c)