I'm getting a type mismatch in the Dlookup below. Note: the ID column in the Results2 Table is formatted as a Number.
If DLookup("[Result" & i & "]", "Results2", "[ID] = '" & newid & "'") <> Me.Controls("C" & 3 + column & "R" & i + j).Value Then
I've tried changing the newid from a string to an Integer or a Long, but I still get this error.
Full code for this Sub below, if more info is needed.
Private Sub BtnSave_Click()
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim rs2 As DAO.Recordset
Dim rs3 As DAO.Recordset
Dim i As Integer
Dim j As Integer
Dim ans As Integer
Dim column As Integer
Dim colcnt As Integer
Dim newid As String
If IsNull(Me.Spindle3.Value) = False Then
colcnt = 3
ElseIf IsNull(Me.Spindle2.Value) = False Then
colcnt = 2
Else
colcnt = 1
End If
column = 1
Set db = CurrentDb
Set rs = db.OpenRecordset("Results")
Set rs2 = db.OpenRecordset("Results2")
Set rs3 = db.OpenRecordset("Results3")
Linestart:
j = 0
rs.AddNew
newid = rs![ID].Value
If Me.Result1.Value = "Fail" Or Me.Result2.Value = "Fail" Or Me.Result1.Value = "Fail" Then
If column = 1 Then
ans = MsgBox("This is a FAILING Result. Do you with to save it?", vbYesNo)
If ans = 7 Then GoTo Lineend
End If
ElseIf Me.Result1.Value = "Incomplete" Or Me.Result2.Value = "Incomplete" Or Me.Result2.Value = "Incomplete" Then
If column = 1 Then
ans = MsgBox("Testing is not finished for this part. Do you with to save and close now?", vbYesNo)
If ans = 7 Then GoTo Lineend
End If
End If
With rs
![PartNum] = Me.FilterPartNumber.Value
![INDNum] = Me.INDNum.Value
![DateTime] = Me.DateTime.Value
![HTLotNum] = Me.HTLotNum.Value
![Operator] = Me.Inspector.Value
![Spindle] = Me.Controls("Spindle" & column).Value
![TypeofCheck] = Me.InspType.Value
![OverallResult] = Me.Controls("Result" & column).Value
End With
rs2.AddNew
With rs2
![ID] = newid
![PartNum] = Me.FilterPartNumber.Value
![Plant] = Me.plantnum.Value
![DateTime] = Me.DateTime.Value
![HTLotNum] = Me.HTLotNum.Value
![Notes] = Me.Notes.Value
![Spindle] = Me.Spindle.Value
![TypeofCheck] = Me.InspType.Value
![OverallResult] = Me.Result1.Value
End With
rs3.AddNew
With rs3
![ID] = newid
![PartNum] = Me.FilterPartNumber.Value
![DateTime] = Me.DateTime.Value
End With
If IsNull(Me.HTLotNum.Value) = True Then
rs![HTLotNum] = "(blank)"
rs![HTLotNum] = "(blank)"
End If
For i = 1 To 90 Step 1
If i + j >= 90 Then
i = 90
GoTo Line1
End If
If IsNull(Me.Controls("C3R" & i + j).Value) = True Then
j = j + 1
End If
If i + j >= 90 Then
i = 90
GoTo Line1
End If
If IsNull(Me.Controls("C2R" & i + j).Value) = True Then GoTo Line1
rs("Char" & i) = Me!ListFeatures.column(1, i - 1)
rs("Desc" & i) = Me!ListFeatures.column(2, i - 1)
rs("Spec" & i) = Me!ListFeatures.column(3, i - 1) & " " & Me!ListFeatures.column(6, i - 1)
rs2("SC" & i) = Me!ListFeatures.column(4, i - 1)
rs2("Location" & i) = Me!ListFeatures.column(5, i - 1)
rs2("Result" & i) = Me.Controls("C" & 3 + column & "R" & i + j).Value
rs3("Coding" & i) = Me!ListCoding.column(1, i - 1)
Line1:
Next
rs.Update
rs2.Update
rs3.Update
For i = 1 To 90 Step 1
If i + j >= 90 Then
i = 90
GoTo Line1
End If
If IsNull(Me.Controls("C3R" & i + j).Value) = True Then
j = j + 1
End If
If i + j >= 90 Then
i = 90
GoTo Line1
End If
If DLookup("[Result" & i & "]", "Results2", "[ID] = '" & newid & "'") <> Me.Controls("C" & 3 + column & "R" & i + j).Value Then
MsgBox "Results not saved! Document results on paper and contact the database engineer regarding this error."
GoTo Lineend:
End If
Next
If column < colcnt Then
column = column + 1
GoTo Linestart
End If
Line2:
Forms![Landing Page]![LIstIncomplete].Requery
DoCmd.Close
Lineend:
End Sub
Per one of the comments, I updated the trouble line to the line below. I'm almost certain that was how I initially wrote this line and added the apostrophes as an attempt to fix.
If DLookup("[Result" & i & "]", "Results2", "[ID] = " & newid) <> Me.Controls("C" & 3 + column & "R" & i + j).Value Then
I had to fix one of my Goto's as well, one of them led to an infinite loop, but now everything is working as intended.
Thanks for the help!
Related
I want to give credit to an agent, if they're the one that sent the message, but only if their signature is at the top of the email.
Here is what I have. The search order is off. The code searches for one name at a time, and clear through the document. I need it to search for All names, the first one that hits in the body of the email.
Sub CountOccurences_SpecificText_In_Folder()
Dim MailItem As Outlook.MailItem
Dim strSpecificText As String
Dim tmpStr As String
Dim x As Integer
Dim Count As Integer
Dim HunterCnt As Integer
Dim SunmolaCnt As Integer
Dim RodriguezCnt As Integer
Dim MammedatyCnt As Integer
Dim MitchellCnt As Integer
Dim TannerCnt As Integer
Dim TAYLORCnt As Integer
Dim WilsonCnt As Integer
Dim WilliamsCnt As Integer
Dim GrooverCnt As Integer
Dim TyreeCnt As Integer
Dim ChapmanCnt As Integer
Dim LukerCnt As Integer
Dim KlinedinstCnt As Integer
Dim HicksCnt As Integer
Dim NATHANIALCnt As Integer
Dim SkinnerCnt As Integer
Dim SimonsCnt As Integer
Dim AgentNames(14) As Variant
AgentNames(0) = "Simons"
AgentNames(1) = "Skinner"
AgentNames(2) = "Mammedaty"
AgentNames(3) = "Hunter"
AgentNames(4) = "Sunmola"
AgentNames(5) = "Rodriguez"
AgentNames(6) = "Mitchell"
AgentNames(7) = "Tanner"
AgentNames(8) = "Taylor"
AgentNames(9) = "Wilson"
AgentNames(10) = "Williams"
AgentNames(11) = "Groover"
AgentNames(12) = "Tyree"
AgentNames(13) = "Chapman"
AgentNames(14) = "Luker"
x = 0
While x < ActiveExplorer.Selection.Count
x = x + 1
Set MailItem = ActiveExplorer.Selection.item(x)
tmpStr = MailItem.Body
For Each Agent In AgentNames
If InStr(tmpStr, Agent) <> 0 Then
If Agent = "Assunta" Then
HunterCnt = HunterCnt + 1
GoTo skip
End If
If Agent = "Sunmola" Then
SunmolaCnt = SunmolaCnt + 1
GoTo skip
End If
If Agent = "Rodriguez" Then
RodriguezCnt = RodriguezCnt + 1
GoTo skip
End If
If Agent = "Mammedaty" Then
MammedatyCnt = MammedatyCnt + 1
GoTo skip
End If
If Agent = "Mitchell" Then
MitchellCnt = MitchellCnt + 1
GoTo skip
End If
If Agent = "Tanner" Then
TannerCnt = TannerCnt + 1
GoTo skip
End If
If Agent = "Taylor" Then
TAYLORCnt = TAYLORCnt + 1
GoTo skip
End If
If Agent = "Wilson" Then
WilsonCnt = WilsonCnt + 1
GoTo skip
End If
If Agent = "Williams" Then
WilliamsCnt = WilliamsCnt + 1
GoTo skip
End If
If Agent = "Groover" Then
GrooverCnt = GrooverCnt + 1
GoTo skip
End If
If Agent = "Tyree" Then
TyreeCnt = TyreeCnt + 1
GoTo skip
End If
If Agent = "Chapman" Then
ChapmanCnt = ChapmanCnt + 1
GoTo skip
End If
If Agent = "Luker" Then
LukerCnt = LukerCnt + 1
GoTo skip
End If
If Agent = "Hicks" Then
HicksCnt = HicksCnt + 1
GoTo skip
End If
End If
Next
skip:
Count = Count + 1
Wend
MsgBox "Found " & vbCrLf & "Hunter Count: " & HunterCnt & vbCrLf & "Sunmola Count: " & SunmolaCnt & vbCrLf & "Rodriguez Count: " & RodriguezCnt & vbCrLf & "Mammedaty Count: " & MammedatyCnt & vbCrLf & "Mitchell Count: " & MitchellCnt & vbCrLf & "Tanner Count: " & TannerCnt & vbCrLf & "Taylor Count: " & TAYLORCnt & vbCrLf & "Wilson Count: " & WilsonCnt & vbCrLf & "Williams Count: " & WilliamsCnt & vbCrLf & "Groover Count: " & GrooverCnt & vbCrLf & "Tyree Count: " & TyreeCnt & vbCrLf & "Chapman Count: " & ChapmanCnt & vbCrLf & "Luker Count: " & LukerCnt & vbCrLf & " in: " & Count & " emails"
End Sub
InStr returns positional information. While it is difficult to find the first occurrence of an array member within the text (you would need to build and compare matches), you can find the first position of each name then find which came first.
For example (untested)
Sub CountOccurences_SpecificText_In_Folder()
Dim MailItem As Outlook.MailItem
Dim i As Long, x As Long, position As Long, First As Long
Dim AgentNames() As String
AgentNames = Split("Simons,Skinner,Mammedaty,Hunter,Sunmola,Rodriguez,Mitchell,Tanner,Taylor,Wilson,Williams,Groover,Tyree,Chapman,Luker", ",")
Dim AgentCount(LBound(AgentNames) To UBound(AgentNames)) As Long
For i = LBound(AgentCount) To UBound(AgentCount)
AgentCount(i) = 0
Next i
For Each MailItem In ActiveExplorer.Selection
x = 0
For i = LBound(AgentNames) To UBound(AgentNames)
position = InStr(MailItem.Body, AgentNames(i))
If x > 0 Then
If position < x Then
x = position
First = i
End If
Else
If position > 0 Then
x = position
First = i
End If
End If
Next i
AgentCount(First) = AgentCount(First) + 1
Next MailItem
For i = LBound(AgentNames) To UBound(AgentNames)
Debug.Print AgentNames(i) & " Count: " & AgentCount(i)
Next i
End Sub
The idea in the previous answer may be better implemented like this:
Option Explicit
Sub CountOccurences_SpecificText_SelectedItems()
Dim objItem As Object
Dim objMail As MailItem
Dim i As Long
Dim j As Long
Dim x As Long
Dim position As Long
Dim First As Long
Dim AgentNames() As String
AgentNames = Split("Simons,Skinner,Mammedaty,Hunter,Sunmola,Rodriguez,Mitchell,Tanner,Taylor,Wilson,Williams,Groover,Tyree,Chapman,Luker", ",")
ReDim AgentCount(LBound(AgentNames) To UBound(AgentNames)) As Long
For j = 1 To ActiveExplorer.Selection.Count
Set objItem = ActiveExplorer.Selection(j)
' Verify before attempting to return mailitem poroperties
If TypeOf objItem Is MailItem Then
Set objMail = objItem
Debug.Print
Debug.Print "objMail.Subject: " & objMail.Subject
x = Len(objMail.Body)
For i = LBound(AgentNames) To UBound(AgentNames)
Debug.Print
Debug.Print "AgentNames(i): " & AgentNames(i)
position = InStr(objMail.Body, AgentNames(i))
Debug.Print " position: " & position
If position > 0 Then
If position < x Then
x = position
First = i
End If
End If
Debug.Print "Lowest position: " & x
Debug.Print " Current first: " & AgentNames(First)
Next i
If x < Len(objMail.Body) Then
AgentCount(First) = AgentCount(First) + 1
Debug.Print
Debug.Print AgentNames(First) & " was found first"
Else
Debug.Print "No agent found."
End If
End If
Next
For i = LBound(AgentNames) To UBound(AgentNames)
Debug.Print AgentNames(i) & " Count: " & AgentCount(i)
Next i
End Sub
Separate and group the strings that have # and without #
Dim Strfinal as String = "#Cccccc,#Aaaaaa,Aaaaa,Baaaa,Caaaa,#Bbbbbb,Abbbbb,Bbbbbb,Cbbbbb"
I want the output like this
#Cccccc, #Aaaaaa(Aaaaa,Baaaa and Caaaa) and #Bbbbbb(Abbbbb,Bbbbbb and Cbbbbb)
I used this code to separate the character that have no #
Dim rws As String
If Aaaaa.Checked = True Then
CheckBox1.Checked = True
close_parenthesis.Checked = True
If rws = "" Then
rws = "(" + Aaaaa.Text
Else
rws = "(" + Aaaaa.Text
End If
End If
If Aaaaa.Checked = False Then
rws = ""
End If
If Baaaa.Checked = True Then
CheckBox1.Checked = True
close_parenthesis.Checked = True
If rws = "" Then
rws = "(" + Baaaa.Text
Else
rws = rws & ", " & Baaaa.Text
End If
End If
If Caaaa.Checked = True Then
CheckBox1.Checked = True
close_parenthesis.Checked = True
If rws = "" Then
rws = "(" + Caaaa.Text
Else
rws = rws & ", " & Caaaa.Text
End If
End If
If close_parenthesis.Checked = True Then
If rws = "" Then
Else
rws = rws + close_parenthesis.Text
End If
End If
CheckBox1.Text = rws.ToString
Me.CagayanReplace.PerformClick()
I used this code for the changing the , to the word and inside the parenthesis
Dim Strng As String = Me.CheckBox1.Text
'now find the position of last appearing ","
Dim comaposition As Integer
comaposition = Strng.LastIndexOf(",") 'it is zero based
'if not found, it will return -1 and u can exit, no need to do the work
If comaposition = "-1" Then
Exit Sub
End If
'remove the comma
Dim String_After_Removing_Comma As String
String_After_Removing_Comma = Strng.Remove(comaposition, 1)
'add "and" in the same position where comma was found
Dim final_string As String
final_string = String_After_Removing_Comma.Insert(comaposition, " and ")
'show it on the textbox
CheckBox1.Text = final_string`
Please help me to solve it.
This here is not a pretty solution and can be optimized a lot. But it gets the job done:
Dim Strfinal As String = "#Cccccc,#Aaaaaa,Aaaaa,Baaaa,Caaaa,#Bbbbbb,Abbbbb,Bbbbbb,Cbbbbb"
Dim splittedString As String() = Strfinal.Split(",")
Dim a As List(Of String) = New List(Of String)
Dim newstr As String = ""
For Each str As String In splittedString
If Not str.Contains("#"c) Then
a.Add(str)
Continue For
End If
If a.Count > 0 Then
Dim b = String.Join(",", a)
Dim i = b.LastIndexOf(","c)
b = b.Remove(i, 1)
b = b.Insert(i, " and ")
newstr += "(" + b + ")," + str
a.Clear()
Else
newstr += str + ","
End If
Next
If a.Count > 0 Then
Dim b = String.Join(",", a)
Dim i = b.LastIndexOf(","c)
b = b.Remove(i, 1)
b = b.Insert(i, " and ")
newstr += "(" + b + ")"
a.Clear()
End If
newstr = newstr.Replace(",(", " (")
Dim z = newstr.LastIndexOf(",#")
newstr = newstr.Remove(z, 1)
newstr = newstr.Insert(z, " and ")
Console.WriteLine(newstr)
Output:
#Cccccc,#Aaaaaa (Aaaaa,Baaaa and Caaaa) and #Bbbbbb(Abbbbb,Bbbbbb and Cbbbbb)
Check it on Fiddle
I am new in Macro VBA and I am facing a problem.
I having two string to compare, and how do I get the string as Result shown if the similarity numbers found in both string?
string 1 : 1,2,3,4,6,7,8,9,10,11,12,13,19,20
string 2 : 2,3,7,8,9,10,11
After comparison:
Result : 2,3,7,8,9,10,11
Code:
If ActiveSheet.Cells(irow + 1, 12).Value = "" Then
'MsgBox "Data not found"
Else
temp = vbNullString
temp = ActiveSheet.Cells(irow + 1, 12).Value
'expanddata() use to expend a sequence of numbers into a display string as below
' 1,2-4,6 -> 1,2,3,4,6
temp = expanddata(temp)
If Worksheets("AI").Cells(irow + 1, 10).Value = temp Then
temp = ConvNum(temp) 'if whole string same then convert back to 1,2-4,6
Else
'the comparision make in here
End If
Worksheets("AI").Cells(irow + 1, 10) = temp
End If
Thank you.
Automating powershell to print the list to a text file c:\temp\test.txt
Sub Test()
a = "(1,2,3,4,6,7,8,9,10,11,12,13,19,20)"
b = "(2,3,7,8,9,10,11)"
cmd = Shell("powershell.exe """ & a & """ | Where {""" & b & """ -Contains $_} | out-file c:\temp\test.txt", 1)
End Sub
For irow = 1 To numofrow
ptcolno = 12
If ActiveSheet.Cells(irow + 1, 12).Value = "" Then
'MsgBox "Data not found"
Else
temp = vbNullString
temp = ActiveSheet.Cells(irow + 1, 12).Value
temp = expanddata(temp)
If Worksheets("AI").Cells(irow + 1, 10).Value = temp Then
temp = ConvNum(temp)
Else
' Answer
Temp2 = Worksheets("AI").Cells(irow + 1, 10).Value
arr1 = Split(Temp2, ",")
arr2 = Split(temp, ",")
temp = vbNullString
For i = LBound(arr2) To UBound(arr2)
For j = LBound(arr1) To UBound(arr1)
If arr2(i) = arr1(j) Then
temp = temp & "," & arr2(i)
End If
Next j
Next i
temp = Right(temp, Len(temp) - 1)
temp = ConvNum(temp)
' End
End If
Worksheets(checktype & "_BUYOFF_1").Cells(irow + 1, 68) = temp
Please try the below code.
Sub comparestring()
string1 = "1,2,3,4,6,7,8,9,10,11,12,13,19,20"
string2 = "2,3,7,8,9,10,11"
str1 = Split(string1, ",")
str2 = Split(string2, ",")
For i = 0 To UBound(str1)
For j = 0 To UBound(str2)
If str1(i) = str2(j) Then
If matchedcontent <> "" Then
matchedcontent = matchedcontent & "," & str1(i)
Else
matchedcontent = str1(i)
End If
End If
Next j
Next i
Range("A3").Value = matchedcontent
End Sub
Assign the two strings to string 1 and string 2 like below results will be printed at Cells A3
string1=Activesheet.Range("A1").Value
string2=Activesheet.Range("A2").Value
try this
Option Explicit
Function CompareStrings(string1 As String, string2 As String) As String
Dim s As Variant
For Each s In Split(string1, ",")
If "," & string2 & "," Like "*," & s & ",*" Then CompareStrings = CompareStrings & s & ","
Next s
CompareStrings = Left(CompareStrings, Len(CompareStrings) - 1)
End Function
which could be called as follows
Sub main()
Dim string1 As String, string2 As String, stringRes As String
string1 = "1,2,3,4,6,7,8,9,10,11,12,13,19,20"
string2 = "2,3,7,8,9,10,11"
stringRes = CompareStrings(string1, string2)
MsgBox stringRes
End Sub
I have designed a macro which should extract from a workbook database all employees who were hired between 2 Dates.
Unfortunatley I'm getting a error mesage when I run the query.
Error:
Data Type mismatch in criteria expression.
I don't know how to fix the issue.
My regional settings:
Short date: dd.MM.yyyy
Long date: dddd, d.MMMM.yyyy
First day of week: Monday
Here the code:
Public Sub HIREDATE()
Application.ScreenUpdating = False
Dim cnStr As String
Dim rs As ADODB.Recordset
Dim query As String
Dim fileName As String
Dim pom1 As String
Dim x As String, w, e, blad As String, opis As String
Set w = Application.FileDialog(msoFileDialogFilePicker)
With w
.AllowMultiSelect = False
If .Show = -1 Then
fileName = w.SelectedItems(1)
Else
Exit Sub
End If
End With
cnStr = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & fileName & ";" & _
"Extended Properties=Excel 12.0"
On Error GoTo Anuluj
x = InputBox("Wprowadz dwie daty od do oddzielając je przecinkiem -- Przykład 01.01.2015,01.05.2015")
strg = ""
k = Split(x, ",")
e = Application.CountA(k)
For m = LBound(k) To UBound(k)
If e = 1 Then
strg = strg & " [DEU1$].[Last Start Date] = '" & k(m) & "';"
Exit For
ElseIf e = 2 And e Mod 2 = 0 Then
strg = " [DEU1$].[Last Start Date] BETWEEN '" & CDate(k(m)) & "' AND '" & CDate(k(m + 1)) & "';"
Exit For
End If
Next m
On Error GoTo opiszblad
Set rs = New ADODB.Recordset
query = "SELECT [Emplid], [First Name]+ ' ' +[Last Name] From [DEU1$] WHERE" & strg
rs.Open query, cnStr, adOpenUnspecified, adLockUnspecified
Cells.Clear
Dim cell As Range, i As Long
With Range("A3").CurrentRegion
.Select
For i = 0 To rs.Fields.Count - 1
.Cells(1, i + 1).Value = rs.Fields(i).Name
Next i
Range("A4").CopyFromRecordset rs
.Cells.Select
.EntireColumn.AutoFit
End With
rs.Close
Application.ScreenUpdating = True
Exit Sub
Anuluj:
Exit Sub
opiszblad:
e = Err.Number
blad = Err.Source
opis = Err.Description
opisbledu = MsgBox(e & " " & blad & " " & opis, vbInformation, "Błąd")
Exit Sub
End Sub
You need properly formatted string expressions for your dates and to validate the user input:
If e = 1 And IsDate(k(m)) Then
strg = strg & " [DEU1$].[Last Start Date] = #" & Format(DateValue(k(m)), "yyyy\/mm\/dd") & "#;"
Exit For
ElseIf e = 2 And e Mod 2 = 0 And IsDate(k(m + 1)) Then
strg = " [DEU1$].[Last Start Date] BETWEEN #" & Format(DateValue(k(m)), "yyyy\/mm\/dd") & "# AND #" & Format(DateValue(k(m + 1)), "yyyy\/mm\/dd") & "#;"
Exit For
End If
I'm currently using the below code in a VB.Net console app that takes the contents of a text file and extracts certain info and then exports it to a CSV.
All seems to work well but the problem is the file originally comes through as a PDF (only option possible) and i have to manually open the file in Adobe and 'Save as Text'.
Is there a way of either automating the conversion of PDF to text file or reading the PDF in place of the text file.
Any guidance or options would be appreciated
Dim iLine, iEnd, c, iField As Integer
Dim iSecs, iMax As Long
Dim sText, sTemp, sSchema As String
Dim sHotel, sEndDate, sMon, sPLU, sTots, sValue, sDept, sFile, sOutFile, sDesc As String
Dim tdate As Date
Dim con As New OleDbConnection("Provider=Microsoft.ACE.OLEDB.12.0; Data Source=C:\temp\TX.accdb;")
Dim LUse As Boolean
sHotel = "Unknown Hotel"
sEndDate = "01/01/2015"
sMon = "MAR"
sPLU = ""
sTots = "0"
sValue = "0"
sDept = "Unknown Dept"
sDesc = ""
LUse = True
sTemp = ""
iField = 0
sSchema = "Chester"
'Open input file
sFile = "c:\temp\input.txt"
Dim InFile As New System.IO.StreamReader(sFile)
'Open lookup data table
con.Open()
Dim dbAdapter As OleDbDataAdapter = New OleDbDataAdapter( _
"SELECT * FROM Plookup", con)
Dim dsTX As DataSet = New DataSet()
Dim changes As DataTable
Dim cmdbuilder As OleDbCommandBuilder = New OleDbCommandBuilder(dbAdapter)
dbAdapter.FillSchema(dsTX, SchemaType.Source, "Plookup")
dbAdapter.Fill(dsTX, "Plookup")
Dim rstx As DataTable = dsTX.Tables(0)
iMax = rstx.Rows.Count
Dim productrow() As Data.DataRow
'Open Output file
iSecs = Timer
sOutFile = "c:\temp\TX" & Format$(Now, "yymmdd") & Trim$(Str$(iSecs)) & ".csv"
FileCopy(sFile, "c:\temp\TX" & Format$(Now, "yymmdd") & Trim$(Str$(iSecs)) & ".txt")
Dim OutFile As New System.IO.StreamWriter(sOutFile)
'Write header
OutFile.WriteLine("outlet,dept,epos,tots sold,total price,date of sales")
iLine = 0
Do While InFile.Peek() <> -1
'Read in text
iLine = iLine + 1
sText = InFile.ReadLine
sText = sText.Replace(",", "")
If Len(sText) > 2 And Len(sText) < 9 Then
If Mid$(sText, 3, 1) = "-" Then ' Department Name
sText = sText & Space(9 - Len(sText))
End If
End If
'Process all rows except header row - read data into array
If Len(sText) > 8 Then
Select Case Left(sText, 7)
Case "Consoli" ' Ignore
Case "Quanti " ' Ignore
Case "Group b" ' Ignore - but next row is the Hotel Name
iLine = iLine + 1
sText = InFile.ReadLine
sText = sText.Replace(",", "")
sHotel = Trim$(Left(sText, 20)) 'The username follows so we may truncate the hotel name
Case "Date ra" ' End date
sEndDate = Mid$(sText, 29, 2) & "/" & Mid$(sText, 32, 2) & "/" & Mid$(sText, 35, 4)
tdate = CDate(sEndDate).AddDays(-1)
sEndDate = tdate.ToString("dd/MM/yyyy")
Case Else 'Possible Code
If Mid$(sText, 3, 1) = "-" Then ' Department Name
sDept = Trim(sText)
Else
If IsNumeric(Left(sText, 7)) Then 'Got a code
sPLU = Trim(Str(Val(Left(sText, 7))))
'We don't know where the description ends as it contains spaces
'So best way is to start at the end and work back...
iEnd = Len(sText)
iField = 0
For c = iEnd To 9 Step -1
If Not (Mid(sText, c, 1) = " ") Or iField > 10 Then
sTemp = Mid(sText, c, 1) & sTemp
Else
iField = iField + 1
If iField = 9 Then
sValue = sTemp
ElseIf iField = 11 Then
sTots = sTemp
End If
sTemp = ""
End If
Next
If iField = 10 Then
sTots = Trim(sTemp)
sDesc = ""
Else
sDesc = Trim$(sTemp)
End If
'lookup code
productrow = rstx.Select("FileID = 'Chester' and PLU = '" & sPLU & "'")
If productrow.Length = 0 Then ' product not found
iMax = iMax + 1
rstx.Rows.Add(sSchema, sPLU, sDesc, False)
LUse = True
Else
LUse = Not productrow(0)("Exclude")
End If
If (Val(sTots) + Val(sValue) > 0) And LUse Then ' We have a non-zero sale or value and it is not excluded
OutFile.WriteLine(sHotel & "," & sDept & "," & sPLU & "," & sTots & "," & sValue & "," & sEndDate)
End If
End If
End If
End Select
End If
Loop
'dbAdapter.Update(dsTX.Tables(0))
'Close input / output csv files
'rstx.Rows.Add("303030", "Another Test", False)
dbAdapter.UpdateCommand = cmdbuilder.GetUpdateCommand(True)
dbAdapter.InsertCommand = cmdbuilder.GetInsertCommand(True)
dbAdapter.DeleteCommand = cmdbuilder.GetDeleteCommand()
changes = rstx.GetChanges()
If changes IsNot Nothing Then dbAdapter.Update(changes)
InFile.Close()
OutFile.Close()
con.Close()
Try itextSharp. itextSharp is a .NET DLL with the help of which you can extract content from PDF. Click here for reference & sample code(although code is in c#, its just a reference to give you an idea).