I'm trying to use the FindFirst command in vba for access with an Array, the Array contains usernames, and I want to search through a table and find the ID of each of the usernames in the array. but I keep getting "Compile Error: Type Mismatch" whenever I press the search button on the access form.
Any ideas? - Also does it look like i am passing the array correctly to the next private sub?
The bit that i'm trying to search with the array starts when I create the username() array.
Private Sub createrel_Click()
'declare variables
Dim stDocName As String, db As Database, RS As Recordset, FindPraNumber As String
Dim vary As Variant
Dim Msg As String
Dim Response As Integer
Dim username() As String
Dim varx() As Variant
If IsNull(Me![userlist]) Then
Msg = "Please choose a pra number from the list"
MsgBox Msg, vbCritical, MsgText
DoCmd.GoToControl "userlist"
Exit Sub
End If
If IsNull(Me![folderlist]) Then
Msg = "Please choose a folder from the list"
MsgBox Msg, vbCritical, MsgText
DoCmd.GoToControl "folderlist"
Exit Sub
End If
username() = Split(Me.userlist, ",")
MsgBox Join(username())
Set db = DBEngine(0)(0)
Set RS = db.OpenRecordset("tblPra", DB_OPEN_DYNASET)
RS.FindFirst "[praNo] = """ & username() & """"
varx() = DLookup("praID", "tblPra", "[praNo] = 'username()'")
Set RS = db.OpenRecordset("tblFolder", DB_OPEN_DYNASET)
RS.FindFirst "[folder] = """ & Me.folderlist & """"
vary = DLookup("folderID", "tblFolder", "[folder] = " & "forms!frmrelationship!folderlist")
Response = MsgBox("You are about to create a relationship. Continue?", vbYesNo)
If Response = vbNo Then
Exit Sub
Else
cmdAddRecord varx(), vary
End If
End Sub
Private Sub cmdAddRecord(x(), y)
Dim stDocName As String, db As Database, RS As Recordset, FindPraNumber As String
Dim exists As Boolean
Dim total As Integer
Set db = DBEngine(0)(0)
Set RS = db.OpenRecordset("tblRelationship", DB_OPEN_DYNASET)
exists = False
If Not RS.EOF Then RS.MoveLast
total = RS.RecordCount
'check to see if relationship exists already
RS.FindFirst "[praID] = " & x() & ""
If RS.NoMatch Then
exists = False
Else
If RS("folderID") = y Then
exists = True
Else
For i = 1 To total Or exists = True
RS.FindNext "[praID] = " & x & ""
If RS.NoMatch Then
Else
If RS("folderID") = y Then exists = True
End If
Next i
End If
End If
If exists = False Then
RS.addNew
RS("praID").Value = x
RS("folderID").Value = y
RS.Update
Msg = "Relationship has now been created"
MsgBox Msg, vbInformation, MsgText
Else
Msg = "Relationship already exists"
MsgBox Msg, vbCritical, MsgText
End If
End Sub
You can't do this:
varx() = DLookup("praID", "tblPra", "[praNo] = 'username()'")
You can't assign an array using DLookup, DLookup can't pull an array of IDs, username() should be username(n), and the concatenating of username is wrong. In fact, the only valid parts in this sentence are "tblPra" and "[praNo] = ".
So rethink your concept. There is no reason to complicate matters when straight recordsets or a query can do the job.
Related
I am trying to design a macro to search for multiple strings in an excel.
I have the following code which searches for the word "techno" in an excel but, I need to include a variable into the code so that I can search for multiple words such "Techno", "electromagnetic", "waves", etc. at once. I am unable to create a loop for this condition.
Can anyone suggest a solution to this problem? The below code works fine but, only a tweak is required to include multiple strings in the search.
Sub SearchFolders()
Dim xFso As Object
Dim xFld As Object
Dim xStrSearch As String
Dim xStrPath As String
Dim xStrFile As String
Dim xOut As Worksheet
Dim xWb As Workbook
Dim xWk As Worksheet
Dim xRow As Long
Dim xFound As Range
Dim xStrAddress As String
Dim xFileDialog As FileDialog
Dim xUpdate As Boolean
Dim xCount As Long
myArray = Array("techno", "magnetic", "laser", "trent")
On Error GoTo ErrHandler
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Select a forlder"
If xFileDialog.Show = -1 Then
xStrPath = xFileDialog.SelectedItems(1)
End If
If xStrPath = "" Then Exit Sub
xUpdate = Application.ScreenUpdating
Application.ScreenUpdating = False
Set xOut = Worksheets.Add
For myCounter = 0 To UBound(myArray)
MsgBox myCounter & " is the Count No."
xStrSearch = myArray(myCounter)
MsgBox xStrSearch & " is the Value fr String search"
xRow = 1
With xOut
.Cells(xRow, 1) = "Workbook"
.Cells(xRow, 2) = "Worksheet"
.Cells(xRow, 3) = "Cell"
.Cells(xRow, 4) = "Text in Cell"
Set xFso = CreateObject("Scripting.FileSystemObject")
Set xFld = xFso.GetFolder(xStrPath)
xStrFile = Dir(xStrPath & "*.xls*")
Do While xStrFile <> ""
Set xWb = Workbooks.Open(Filename:=xStrPath & "\" & xStrFile, UpdateLinks:=0, ReadOnly:=True, AddToMRU:=False)
For Each xWk In xWb.Worksheets
Set xFound = xWk.UsedRange.Find(xStrSearch)
MsgBox xFound & " is the strings found"
If Not xFound Is Nothing Then
xStrAddress = xFound.Address
End If
Do
If xFound Is Nothing Then
Exit Do
Else
xCount = xCount + 1
MsgBox xCount & " is the count of strings"
xRow = xRow + 1
.Cells(xRow, 1) = xWb.Name
.Cells(xRow, 2) = xWk.Name
.Cells(xRow, 3) = xFound.Address
.Cells(xRow, 4) = xFound.Value
End If
Set xFound = xWk.Cells.FindNext(After:=xFound)
MsgBox xFound & " next string"
MsgBox xStrAddress & " is the address "
MsgBox xFound.Address & " is the address found"
Loop While xStrAddress <> xFound.Address 'To check how xStrAddress is populated or do we need to declare it as a help from excel pointed out
myCounter = myCounter + 1
Next
xWb.Close (False)
xStrFile = Dir
Loop
.Columns("A:D").EntireColumn.AutoFit
End With
Next myCounter
MsgBox xCount & "cells have been found", ,
ExitHandler:
Set xOut = Nothing
Set xWk = Nothing
Set xWb = Nothing
Set xFld = Nothing
Set xFso = Nothing
Application.ScreenUpdating = xUpdate
Exit Sub
ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitHandler
End Sub
If the strings you are searching will always be the same, hard code them into an array and Loop through the array elements to search each string, like so:
Dim myArray as Variant
Dim myCounter as Long
myArray = Array("techno", "electromagnetic", ...etc.)
For myCounter = 0 To UBound(myArray)
... 'your code here
xStrSearch = myArray(myCounter)
... 'the rest if your code here
Next myCounter
I am having problems getting my array to write to a txt.file correctly.
What it does currently, is display the results in a msgbox so we can see it straight away, and writes only some of the data that appeared in that msgbox into the txt.file.
I tried using 'Append' which does display all the data, but of course, it only adds the data to the txt.file rather than replacing what is already in there.
'Output' I think is the only way of getting it to write all the data into the txt.file, and then also replace it each time.
Sadly, I cannot get it to work with 'output'. It currently only writes the last line of data that was in the array.
I assume I need some kind of loop, but I cannot figure out a way to get it to work successfully.
My code is below. Any help would be appreciated.
Private Function Expired(ByRef msg As String, ByRef var1 As Variant, ByRef
var2 As Variant, ByRef var3 As Variant) As String
Dim sFilePath As String
Dim FileNumber
If Len(msg) = 0 Then msg = "Persons with EXPIRED Safeguading
Certificates:#NL#NL"
Expired = msg & "#var1 #var2 (#var3)#NL"
Expired = Replace(Expired, "#var1", var1)
Expired = Replace(Expired, "#var2", var2)
Expired = Replace(Expired, "#var3", var3)
sFilePath = "R:\HR and Admin\Expired.txt"
FileNumber = FreeFile
If (VBA.Len(VBA.Dir(sFilePath))) = 0 Then MsgBox "File Does not exists": End
Open sFilePath For Output As #FileNumber
Print #FileNumber , var1, var2, var3
Close #FileNumber
The following is all the code for the vba sheet:
Public Sub Expire_New(ByRef ws As Worksheet, ByVal Name As String)
Dim msg(1 To 3) As String
Dim x As Long
Dim nDx As Long
Dim dDiff As Long
'Establish the location of the first cell (range) of the Safegaurding Training block
'Find the first instance of Safeguarding Training on the sheet
Dim sgTrainingCol As Range
With ws.Range("A1:AA1000") 'Using something large to provide a range to search
Set sgTrainingCol = .Find("Safeguarding Training", LookIn:=xlValues)
End With
'Establish the location of the first cell (range) of the heading column
'for the table on the sheet. Find the first instance of what is contained
'in mTitleFirstHeadingColumn
Dim HeadingRangeStart As Range
With ws.Range("A1:AA1000") 'Using something large to provide a range to search
Set HeadingRangeStart = .Find(Name, LookIn:=xlValues)
End With
Dim TrainingInfoRange As Range
Dim personFNSR As Range
With ws
'finds the last row of the Heading column that has data, there can NOT be any empty rows
'in the middle of this search. It assumes that the name column date is contigous until
'reaching the end of the data set.
x = .Cells(HeadingRangeStart.Row, HeadingRangeStart.Column).End(xlDown).Row
'Set the TrainingInfoRange to point to the data contained in the 4 columns under Safeguarding Training
Set TrainingInfoRange = .Range(.Cells(sgTrainingCol.Row + 2, sgTrainingCol.Column), .Cells(x, sgTrainingCol.Column + 3))
'Set pseronFNSR to the First Name/Name, Surname range
Set personFNSR = .Range(.Cells(HeadingRangeStart.Row + 1, HeadingRangeStart.Column), .Cells(x, HeadingRangeStart.Column + 1))
End With
'I am a big fan of collections and scripting dictionaries.
'They make code easier to read and to implement.
Dim trainingDate As Scripting.Dictionary
Set trainingDate = CopyRngDimToCollection(personFNSR, TrainingInfoRange)
'This boolean will be used to control continued flow of the
'macro. If NoExpiredTraining gets set to false, then there
'are people who must complete training.
Dim NoExpiredTraining As Boolean: NoExpiredTraining = True
'person training inquiry object - see class definition
Dim personInquiryTraining As clPersonTraining
'this is an index variable used to loop through items
'contained in the Scripting Dictionary object
Dim Key As Variant
For Each Key In trainingDate.Keys
'Assing the next object in the trainingDate Scripting Dictionary
'to the person training inquiry object
Set personInquiryTraining = trainingDate(Key)
'Check to see if there are any training issues
'if so, then set NoExpiredTraining to False
'because there is expired, expiring or missing training
If personInquiryTraining.ExpiringTraining _
Or personInquiryTraining.NoTraining _
Or personInquiryTraining.TrainingExpired Then
NoExpiredTraining = False
End If
Next
If NoExpiredTraining Then
'msg(4) = MsgBox("There are either no ...
'is only used if want to do something based on
'what button the user pressed. Otherwise use
'the Method form of MsgBox
MsgBox "There are either no expired safeguarding certificates, " _
& "or no certificate expiring within the next 31 days.", _
vbInformation, "Warning"
Exit Sub
End If
'If this code executes, then there is expired training.
'Let's collect the status for each individual
For Each Key In trainingDate.Keys
Set personInquiryTraining = trainingDate(Key)
If personInquiryTraining.TrainingExpired _
And personInquiryTraining.trainingDate <> DateSerial(1900, 1, 1) Then 'Training is expired
msg(1) = Expired(msg(1), _
personInquiryTraining.firstName, _
personInquiryTraining.surName, _
personInquiryTraining.trainingExpiryDate)
End If
If personInquiryTraining.ExpiringTraining _
And personInquiryTraining.trainingExpiryDate <> DateSerial(1900, 1, 1) Then 'Training is expiring
msg(2) = Expiring(msg(2), _
personInquiryTraining.firstName, _
personInquiryTraining.surName, _
personInquiryTraining.trainingExpiryDate, _
DateDiff("d", Date, personInquiryTraining.trainingExpiryDate))
End If
If personInquiryTraining.NoTraining Then 'Training is None
msg(3) = NoTraining(msg(3), _
personInquiryTraining.firstName, _
personInquiryTraining.surName, _
"NONE")
End If
Next
'Because of the Exit Sub statement above, the code bwlow
'will only execute if there are expired, expiring or missing
'training
For x = LBound(msg) To UBound(msg)
msg(x) = Replace(msg(x), "#NL", vbCrLf)
If Len(msg(x)) < 1024 Then
Select Case msg(x)
Case msg(1)
If Len(msg(x)) & vbNullString > 0 Then
'MsgBox "(If this box is blank, there is nothing Expired)" & vbCrLf & vbCrLf & msg(x), vbExclamation, "Safeguarding Certificate Notification"
MsgBox msg(x), vbCritical, "Safeguarding Certificate Notification"
End If
Case msg(2)
If Len(msg(x)) & vbNullString > 0 Then
'MsgBox "(If this box is blank, there is nothing Expired)" & vbCrLf & vbCrLf & msg(x), vbExclamation, "Safeguarding Certificate Notification"
MsgBox msg(x), vbExclamation, "Safeguarding Certificate Notification"
End If
Case msg(3)
If Len(msg(x)) & vbNullString > 0 Then
'MsgBox "(If this box is blank, there is nothing Expired)" & vbCrLf & vbCrLf & msg(x), vbExclamation, "Safeguarding Certificate Notification"
MsgBox msg(x), vbCritical, "Safeguarding Certificate Notification"
End If
End Select
Else
MsgBox "String length for notification too long to fit into this MessageBox", vbExclamation, "Invalid String Length to Display"
End If
Next x
End Sub
'***************************************************************************
'**
'** This fucntion copies all rows of data for the column specified into
'** a scripting dictionary
Private Function CopyRngDimToCollection(ByRef mFNSR As Range, ByRef
mTrainInfo) As Scripting.Dictionary
Dim retVal As New Scripting.Dictionary
'nDx will become a key for each of the scripting dictionary items
Dim nDx As Long: nDx = 1
'person training inquiry object - see class definition
Dim personTraining As clPersonTraining
Dim mRow As Range
For Each mRow In mFNSR.Rows
'instantiate a new person training inquiry object
Set personTraining = New clPersonTraining
With personTraining
.firstName = mRow.Value2(1, 1)
.surName = mRow.Value2(1, 2)
End With
retVal.Add nDx, personTraining
nDx = nDx + 1
Next
nDx = 1
For Each mRow In mTrainInfo.Rows
'Retrieve the person training inquiry object
'from the scripting dictionary (retVal)
Set personTraining = retVal(nDx)
'Add the training data information to
'the person training inquiry object
With personTraining
'Next two equations determine if the excel range has a null value
'if so then the person training inquiry object's date field is set to a
'default value of 1-1-1900 - this could be any valid date
'otherwise the value is set to what is in the excel range from the sheet
.trainingDate = IIf(mRow.Value2(1, 1) = vbNullString, DateSerial(1900, 1, 1), mRow.Value2(1, 1))
.trainingExpiryDate = IIf(mRow.Value2(1, 2) = vbNullString, DateSerial(1900, 1, 1), mRow.Value2(1, 2))
.trainingLevel = mRow.Value2(1, 3)
.certSeenBy = mRow.Value2(1, 4)
End With
'Update the object stored at the current key location
'given by the value of nDx
Set retVal(nDx) = personTraining
nDx = nDx + 1
Next
'Set the return value for the function
Set CopyRngDimToCollection = retVal
End Function
Private Function Expired(ByRef msg As String, ByRef var1 As Variant,
ByRef var2 As Variant, ByRef var3 As Variant) As String
Dim sFilePath As String
Dim FileNumber
If Len(msg) = 0 Then msg = "Persons with EXPIRED Safeguading
Certificates:#NL#NL"
Expired = msg & "#var1 #var2 (#var3)#NL"
Expired = Replace(Expired, "#var1", var1)
Expired = Replace(Expired, "#var2", var2)
Expired = Replace(Expired, "#var3", var3)
sFilePath = "R:\HR and Admin\Expired.txt"
FileNumber = FreeFile
If (VBA.Len(VBA.Dir(sFilePath))) = 0 Then MsgBox "File Does not exists":
End
Open sFilePath For Output As #FileNumber
Print #FileNumber, var1, var2, var3
Close #FileNumber
End Function
Private Function Expiring(ByRef msg As String, ByRef var1 As Variant,
ByRef var2
As Variant, ByRef var3 As Variant, ByRef d As Long) As String
Dim sFilePath As String
Dim FileNumber
If Len(msg) = 0 Then msg = "Persons with EXPIRING Safeguarding
Certificates:#NL#NL"
Expiring = msg & "#var1 #var2 (#var3) (#d days remaining)#NL"
Expiring = Replace(Expiring, "#var1", var1)
Expiring = Replace(Expiring, "#var2", var2)
Expiring = Replace(Expiring, "#var3", var3)
Expiring = Replace(Expiring, "#d", d)
sFilePath = "R:\HR and Admin\Expiring.txt"
FileNumber = FreeFile
If (VBA.Len(VBA.Dir(sFilePath))) = 0 Then MsgBox "File Does not exists":
End
Open sFilePath For Output As #FileNumber
Print #FileNumber, var1, var2, var3
Close #FileNumber
End Function
Private Function NoTraining(ByRef msg As String, ByRef var1 As Variant,
ByRef var2 As Variant, ByRef var3 As Variant) As String
Dim sFilePath As String
Dim FileNumber
If Len(msg) = 0 Then msg = "SAFEGUARDING TRAINING NOT COMPLETED FOR:
#NL#NL"
NoTraining = msg & " #var1 #var2#NL"
NoTraining = Replace(NoTraining, "#var1", var1)
NoTraining = Replace(NoTraining, "#var2", var2)
NoTraining = Replace(NoTraining, "#var3", var3)
sFilePath = "R:\HR and Admin\NoTraining.txt"
FileNumber = FreeFile
If (VBA.Len(VBA.Dir(sFilePath))) = 0 Then MsgBox "File Does not exists":
End
Open sFilePath For Output As #FileNumber
Print #FileNumber, var1, var2, var3
Close #FileNumber
End Function
You need to open the file once instead of looping over the file open. The easiest way to change your existing code is to open all 3 files before you start the loop, and then close them when you're done. Then pass the open file handle to the procedure that writes it:
Dim expiredFile As Integer, expiringFile As Integer, notrainingFile As Integer
expiredFile = FreeFile
Open "R:\HR and Admin\Expired.txt" For Output As #expiredFile
expiringFile = FreeFile
Open "R:\HR and Admin\Expiring.txt" For Output As #expiringFile
notrainingFile = FreeFile
Open "R:\HR and Admin\NoTraining.txt" For Output As #notrainingFile
For Each Key In trainingDate.Keys
Set personInquiryTraining = trainingDate(Key)
If personInquiryTraining.TrainingExpired _
And personInquiryTraining.trainingDate <> DateSerial(1900, 1, 1) Then
'Training is expired
msg(1) = expired(expiredFile, msg(1), _
personInquiryTraining.firstName, _
personInquiryTraining.surName, _
personInquiryTraining.trainingExpiryDate)
End If
'...
Next
Close #expiredFile
Close #expiringFile
Close #notrainingFile
Called function example:
Private Function expired(FileNumber As Integer, ByRef msg As String, ByRef var1 As Variant, _
ByRef var2 As Variant, ByRef var3 As Variant) As String
expired = msg & "#var1 #var2 (#var3)#NL"
expired = Replace(expired, "#var1", var1)
expired = Replace(expired, "#var2", var2)
expired = Replace(expired, "#var3", var3)
Print #FileNumber, var1, var2, var3
End Function
Note that this is somewhat of a hack to fit your existing code, because you are doing too much in the calling procedure. A much better solution would be to separate the selection logic (your calling loop) from the file output entirely. It would be much more robust if you processed the array first, pushing the results into a Collection or some other container, and then had a single "write" function that takes a file name to generically write them to a passed file name.
I fixed your code. You missed Semicolon in your Print that why it didn't work.
Option Explicit
Private Function Expired( _
ByRef msg As String, _
ByRef var1 As Variant, _
ByRef var2 As Variant, _
ByRef var3 As Variant _
) As String
' Init Vars
Dim msg_ As String
Dim Block As String
Dim sFilePath As String: sFilePath = "R:\HR and Admin\Expired.txt"
Dim FileNumber As Integer: FileNumber = FreeFile
' Check if msg has no value
If msg = vbNullString Then msg_ = "Persons with EXPIRED Safeguading Certificates:#NL#NL"
Block = msg & _
"#" & var1 & " " & _
"#" & var2 & " " & _
"(#" & var3 & ")#NL"
' Text File
If Dir(sFilePath) = vbNullString Then
MsgBox "File Does not exists"
' Return nothing
Expired = vbNullString
Else
Open sFilePath For Output As #FileNumber
Print #FileNumber, var1, var2, var3;
Close #FileNumber
' Return Block
Expired = Block
End If
End Function
Private Sub CommandButton1_Click()
Debug.Print Expired("f", 1, 2, 3)
End Sub
I am new in Access been trying this for over 3days now. im tyingin to create a module or anything that when a press a button from a form the module will show a file dialog. get the .txt file and insert it into a table
here is how far i have got
Private Sub FileUpload()
'Requires reference to Microsoft Office 12.0 Object Library.
Dim fDialog As Office.FileDialog
Dim varFile As Variant
Const MyFile = "TXT_Import_Spec" 'change to suit
'Clear listbox contents.
'Me.FileList.RowSource = ""
'Set up the File Dialog.
Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
With fDialog
'Allow user to make multiple selections in dialog box.
.AllowMultiSelect = False
'Set the title of the dialog box.
.Title = "Please choose FM16 text files"
'Clear out the current filters, and add our own.
.Filters.Clear
.Filters.Add ".txt FM16 Files", "*.TXT"
.Show
obJaces
'Import Myfile
DoCmd.TransferText acImportDelim, "TXT_Import_Spec", "DM1", "MyFile", False
'Delete old records from Tbl_Import
'CurrentDb.Execute "DELETE * FROM DM1"
'Add new records to Tbl_Import
CurrentDb.Execute "INSERT INTO DM1 SELECT * FROM MyFile WHERE MyFile.JobNo IN (SELECT MyFile.JobNo FROM MyFile LEFT JOIN Tbl_Import ON MyFile.JobNo = Tbl_Import.JobNo WHERE Tbl_Import.JobNo Is Null)"
'Delete Myfile Table
CurrentDb.Execute "DROP TABLE MyFile"
End With
End Sub
been a stress full week. will appreciate any help.
#DonGeorge I have manage to get the script working please check the script below but the problem is its taking for ever. because the txt file has like 900,000 records.
so what i did to avoid overflow error is the script to show notification in every 100,000 records uploaded. but that takes like 5 mins for a good computer.
Option Compare Database
Sub uploadData()
On Error GoTo 11:
Dim strFile As String
Dim db As DAO.Database
Dim rs1 As DAO.Recordset
Dim cnt As Double
strFile = GetFile
If strFile <> "" Then
Set db = CurrentDb()
Set rs1 = db.OpenRecordset("BM1")
Dim firstLine As Boolean
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.OpenTextFile(strFile)
firstLine = False
msg = MsgBox("Do you want to delete all records from BM1 before loading ?", vbCritical + vbYesNo, "Upload File")
If msg = vbYes Then
DoCmd.SetWarnings False
DoCmd.RunSQL "delete * from BM1"
DoCmd.SetWarnings True
End If
Do Until objFile.AtEndOfStream
strEmployee = objFile.ReadLine
If firstLine = True Then
arrEmployee = Split(strEmployee, ",")
If UBound(arrEmployee) = 20 Then
rs1.AddNew
For i = 0 To rs1.Fields.Count - 1
rs1.Fields(i).Value = Replace(arrEmployee(i), """", "")
Next
rs1.Update
End If
Else
firstLine = True
End If
cnt = cnt + 1
If cnt Mod 100000 = 0 Then
MsgBox "Records Added " & cnt
End If
Loop
rs1.Close
MsgBox "Records Upload Completed"
End If
Exit Sub
11:
MsgBox Err.Description
End Sub
Function GetFile() As String
Dim f As Object
Set f = Application.FileDialog(3)
Dim varfile As Variant
f.AllowMultiSelect = False
f.Filters.Clear
f.Filters.Add "Text File", "*.txt"
f.Show
For Each varfile In f.selecteditems
GetFile = varfile
Exit For
Next varfile
End Function
How can I convert a row data into string or text and display it into a label? My problem is when I click on my login button which contains the SQL code that gains a row data into alabel, the result in my label is false. not the text. How can I convert it into string?
Here's my code:
Private Sub cmdLog_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles cmdLog.Click
Dim connection As New SqlClient.SqlConnection
Dim command As New SqlClient.SqlCommand
Dim adaptor As New SqlClient.SqlDataAdapter
Dim dataset As New DataSet
Dim reader As MySqlDataReader = Nothing
Dim sapi
sapi = CreateObject("sapi.spvoice")
connection.ConnectionString = ("Data Source=.\SQLEXPRESS;AttachDbFilename=C:\Users\Calupad\Desktop\HTF feat Yiyet\HTF feat Yiyet\Database1.mdf;Integrated Security=True;User Instance=True")
command.CommandText = "SELECT * FROM [Users] WHERE Username='" & txtUser.Text & "' AND Password ='" & txtPass.Text & "';"
txtWel.Text = "Welcome Back, " + txtUser.Text + "!....."
connection.Open()
command.Connection = connection
adaptor.SelectCommand = command
adaptor.Fill(dataset, "0")
txtStat.text = command.CommandText = "SELECT Status FROM [Users] WHERE Username = '" & txtUser.Text & "' ".ToString
txtStat.Text = stat
Dim count = dataset.Tables(0).Rows.Count
If count > 0 Then
MsgBox("Login Successful!" & vbNewLine & txtStat.Text, MsgBoxStyle.Information, "Access Granted")
sapi.speak(txtWel.Text)
Me.Hide()
Form1.Show()
frmMenu.Show()
txtUser.Clear()
txtPass.Clear()
tries = 3
Else
ctr = tries - 1
tries = ctr
sapi.speak(txtUser.Text + txtNot.Text)
MsgBox("Invalid Account!" + vbNewLine + "Attempts Remaining: " & tries, vbCritical, "Access Denied")
txtUser.Clear()
txtPass.Clear()
If tries = 0 Then
MsgBox("You've reached the maximum attempts!" + vbNewLine + "The program will be terminated.", vbCritical, "Terminated!")
Me.Close()
End If
End If
End Sub
First of all, the way you check for username and password is weak and is most certainly volnurable to SQL injections. You are checking if the 'count' of rows is greater than zero then the user has logged in successfully, where as you should only compare count to 1. and instead of counting the rows, try to compare the row values to what the user has input in the username and passoword fields and what is returned from the database rows.
The "hacker" can simply type this and he will be allowed to log in according to the logic of your code:
You just need to retrieve the data stored into dataset variable that you filled using the adapter.
Assuming your database table contains fields like First_Name and 'Last_Name', here is how you can display them on any label control on your form:
adaptor.Fill(dataset, "0")
myFirstName.Text = dataset.Tables(0).Rows(0).Item("First_Name").ToString()
myLastName.Text = dataset.Tables(0).Rows(0).Item("First_Name").ToString()
You can also retrieve the column without having to know its name like this
myLabel.text = = dataset.Tables(0).Rows(0).Item(3).ToString()
'This will retrieve the 4th column from the table (zero based array)
You can also clean up your code by declaring a variable to hold the retrieved table
adaptor.Fill(dataset, "0")
Dim myTable as DataTable = dataset.Tables(0)
myFirstName.Text = myTable.Rows(0).Item(0).ToString()
Hope this helps
I am having trouble with an asp page that contains a random function to display a random number of random records. The way I have the code now, as shown below, nothing appears on the page even though there are several records that match the criteria.
Out of 500 records I have in my database, about 70 match the criteria, but form some reason, they never seem to fall within the plist variable, to be used in the query.
When I change the max number to a lower number, say 10, I get an error message that the EOF has been found or no more records are available. Using debugging code, I couldnt find anything out of the ordinary, just the fact that from all the 100 records input into the plist, none of them match the records from the main criteria.
I am posting the entire code here. Maybe someone can catch what may be causing to not work properly.
Sub GetRandomDomains
dim conn, maxrecords, count, webname
dim randomrs, sql
'If (conn.State = adStateClosed) Then
OpenDB conn
'End If
count=0
maxrecords=100
KeywordColumnGetRandomKeywords conn, maxrecords, sql
If sql="" then
conn.close
set conn=nothing
Response.Write(" NOT AVAILABLE")
exit sub
end if
set randomrs=conn.execute(sql)
Response.Write("<ul id='catnav'>")
do While Not randomrs.EOF and count<maxrecords
If isnull(randomrs("sitename")) Then
webname=randomrs("domain")
Else
webname=randomrs("sitename")
End if
Response.Write "<li> " & webname &"</li>"
count=count+1
randomrs.movenext
loop
Response.Write("</ul>")
CloseSet randomrs
CloseDB conn
end sub
Sub KeywordColumnGetRandomKeywords (conn,maxrecords,sql)
dim i, id, index, plist, rs, sqlstr, sortstr
plist=""
Set rs=Server.CreateObject("ADODB.Recordset")
sqlstr="SELECT domainid FROM domains"
sqlstr=sqlstr
Debugwrite sqlstr, "sqlstr for random domains"
rs.Open sqlstr,conn,3,3
If rs.eof then
CloseSet rs
Response.Write(" EMPTY")
sql=""
exit sub
end if
Debugwrite rs("domainid"), "rs for random domains"
Dim arrData ' Array to Store Data
Dim arrSequence ' Array to Hold Random Sequence
Dim iArrayLooper ' Integer for Looping
Dim iarraysize ' Size of Data Array
If xdbasetype="Local" Then
iarraysize=cint(rs.recordcount)
else
iarraysize=cint(GetRecordcount (conn))
end if
Debugwrite GetRecordcount(conn), "getrecordcount for random domains array"
Debugwrite(IsArray(iarraysize)), "random domains count array"
'if (cint(GetRecordcount(conn)))= 0 or isnull(cint(GetRecordcount(conn))) then
'Exit Sub
'End if
redim arrdata(cint(iarraysize))
for i = 0 to iarraysize-1
arrData(i)=rs(0)
rs.movenext
next
rs.close
Set rs = Nothing
If iarraysize<maxrecords then
maxrecords=iarraysize
end if
' Get an array of numbers 0 to array size randomly sequenced.
arrSequence = Resequencearray(iArraySize)
for i = 0 to maxrecords-1
index=arrsequence(i)
id=arrdata(index)
if plist<>"" then
plist=plist & ","
end if
plist=plist & id
Next
sql="select domainid, domain, sitename,sitematch,altmatch from domains"
sql = sql & " WHERE restricted=0 and(sitematch like '%" & xsitematch & "%' or altmatch like '%" & xaltmatch & "%')"
sql = sql & " and domainid In (" & plist & ") "
Debugwrite sql, "first sql for random domains"
end sub
Function ResequenceArray(iArraySize)
Dim arrTemp()
Dim I
Dim iLowerBound, iUpperBound
Dim iRndNumber
Dim iTemp
' Set array size
ReDim arrTemp(iArraySize - 1)
Randomize
iLowerBound = LBound(arrTemp)
iUpperBound = UBound(arrTemp)
For I = iLowerBound To iUpperBound
arrTemp(I) = I
Next
' Loop through the array once, swapping each value
' with another in a random location within the array.
For I = iLowerBound to iUpperBound
iRndNumber = Int(Rnd * (iUpperBound - iLowerBound + 1))
' Swap Ith element with iRndNumberth element
iTemp = arrTemp(I)
arrTemp(I) = arrTemp(iRndNumber)
arrTemp(iRndNumber) = iTemp
Next 'I
' Return our array
ResequenceArray = arrTemp
End Function
'***********************************************************************
' get record count for mysql
'************************************************************************
Function GetrecordCount(conn)
dim sqlstr, rs, rcount
sqlstr="select count(domainid) FROM domains WHERE restricted=0 and (domaingroup='" & xdomaingroup & "' or altmatch like '%" & xaltmatch & "%')"
Debugwrite sqlstr, "sqlstr for random domains"
set rs=conn.execute(sqlstr)
if rs.eof then
rcount=0
else
rcount=rs(0)
end if
CloseSet rs
Getrecordcount=cint(rcount)
Debugwrite rcount, "getrecordcount for random domains"
End function
Okay. There may be a far more simple way of approaching this. Here's a piece of code that gets the data as an array - far simpler and we have much more control over what's in it...
'Constants relating to the following routines...
const C_NO_DATA = "NO_DATA" 'Used when no data is returned to a consuming routine
const C_ERROR = "ERROR" 'Used when an error is generated
'GetDataSet
' Returns a table of data based on the supplied SQL statement and connection string.
'Parameters:
' sqlString (string) - The SQL string to be sent.
' connString (string) - The database connection string.
'Usage:
' dataSet = GetDataSet(sqlString, connString)
'Description:
' This function generates a table of information in a 2 dimensional array. The first dimension represents the columns
' and the second the rows. If an error occurs while the routine is executing the array and the base index (0,0) is set
' to C_ERROR, (0,1) to the VBScript error index, and (0,2) to the VBScript error description.
function GetDataSet(sqlString, connString)
'Initialise...
dim returnVal, rsData
on error resume next
'Define and open the recordset object...
set rsData = Server.CreateObject("ADODB.RecordSet")
rsData.Open sqlString, connString, 0, 1, 1
'Initialise an empty value for the containing array...
redim returnVal(0,0)
returnVal(0,0) = C_NO_DATA
'Deal with any errors...
if not rsData.EOF and not rsData.BOF then
'Store the data...
returnVal = rsData.GetRows()
'Tidy up...
rsData.close
set rsData = nothing
select case err.number
case 3021 'No data returned
'Do nothing as the initial value will still exist (C_NO_DATA)
case 0 'No error
'Do nothing as data has been returned
case else
redim returnVal(4,0)
returnVal(0,0) = C_ERROR
returnVal(1,0) = err.number
returnVal(2,0) = err.description
returnVal(3,0) = sqlString
returnVal(4,0) = connString
end select
end if
on error goto 0
'Return the array...
GetDataSet = returnVal
end function
Okay, so we read the data we're after into an array. Note that I don't know where your xaltmatch and xsitematch variables come from so you'll need to supply these at some point...
Dim ds, sql
sql = _
"SELECT " & _
"domainid, " & _
"domain, " & _
"sitename, " & _
"sitematch, " & _
"altmatch " & _
"FROM " & _
"domains " & _
"WHERE " & _
"restricted=0 AND " & _
"(sitematch LIKE '%" & xsitematch & "%' OR " & _
"altmatch LIKE'%" & xaltmatch & "%') AND " & _
"domainid IN (" & plist & ") "
ds = GetDataSet(sql, conn)
The ds variable now contains an array of elements pulled from the database. All we need to do now is loop through the required number of times...
dim row, rows, used, randoms, col, cols, rc, cc
rows = UBound(ds, 2) 'Get the upper bound of the second array dimension
cols = UBound(ds, 1) 'Get the number of columns for writing to the page
randoms = 70 'Total number of randoms we need
used = ","
for rc = 1 to randoms
'Just in case we don't want to repeat the same row...
do
row = int(rnd(1)*rows) 'Zero based - we don't need to add 1
until instr(used, "," & row & ",")) = 0
'Add our random row to the list...
used = used & row & ","
'Write our output to the page...
response.write("<table>")
for cc = 0 to cols
response.write("<tr>")
response.write("<td>")
response.write(ds(cc, row))
response.write("</td>")
response.write("</tr>")
next 'cc
response.write("</table>")
next 'rc
The GetDataSet code is part of my stock functions, so I know that works, but I will hold my hand up and say that I haven't tested the rest of it.
Have a bash with this one, Luis, and let me know how you get on.