Related
I have a system where when user click button submit it will insert the data into the table database and also send an email to the user. My problem is I want to put a link into the email.Body so that the user can click the link to the Approval page. But when I click the link it says the sites can't be reached and the id=0. Every Functions work well, I just have a problem with the link.
Here is my sendMessage() code :
Private Sub SendMessage()
Dim mail As MailMessage = New MailMessage
mail.From = New MailAddress("notice#example.com")
mail.To.Add(New MailAddress("user1#example.com"))
mail.Subject = "Test Approval"
Dim link As String
Dim intID As Integer
link = "Click here"
mail.Body = "<br/><br/>Employee No : " & lblEmpNO.Text.Trim(Environment.NewLine, "<br />") & "<br/><br/>Employee Name : " & lblemployeename.Text.Trim & link
mail.IsBodyHtml = True
Dim client As New SmtpClient()
client.EnableSsl = True
Try
client.Send(mail)
'MsgBox("Sending Email succeeded")
Catch ex As Exception
'MsgBox("Sending Email failed. Please try again")
End Try
End Sub
Here is LoadEmployeeDetailsById(intID) :
Private Function LoadEmployeeDetailsById(ByVal intid As Integer) As String
Using GetdutyDetails As New clsExternalWorkDuty_func
Dim dt As New DataTable
Dim result As String = ""
dt = GetdutyDetails.GetAllDataTableExternalWorkdutyDetailsByID(intid) 'Call the Function from AppCode
If dt.Rows.Count > 0 Then
pnlApproval.Visible = True
End If
Return result
End Using
End Function
Here is btnSubmit() :
Protected Sub btnSubmit_Click(sender As Object, e As EventArgs) Handles btnSubmit.Click
If InsertData(lblhdddnuserid.Text, lblhddnEmployeedeptid.Text) = 1 Then
DisplayMessage("success", "Done", "Data succesfully inserted!")
SendMessage()
LoadEmployeeByuserid(Membership.GetUser.ProviderUserKey)
End If
End Sub
Your SQL must be modified to return a scalar value of the Id. If the ID is an IDENTITY column then you can call SELECT SCOPE_IDENTIY() at the end of your statement. Or you can use the OUTPUT directive, as below:
INSERT INTO [YourTable] ([Field1], [Field2], [Field3])
OUTPUT INSERTED.ID VALUES (#Value1, #Value2, #Value3)
The adjust your InsertData function to return an object as the result
Public Class InsertDataResult
Public Property Success As Boolean
Public Property InsertedId As Integer
End Class
I am creating a user login system using vb.net and MS access. I am unsure what is going wrong with my system and I receive the error message "Item cannot be found in the collection corresponding to the requested name or ordinal" The error is coming up in the section "User.Find(Username)" on the first line of the DO loop. Here is my code:
Public Class Login
Dim LoginError As String ' This will tell the user what is wrong with his login
Public Function Login()
Dim DBConn As New ADODB.Connection ' This is how we tell visual studio
'how to connect to our database
Dim User As New ADODB.Recordset 'We pass our argument through our recordset
Dim Username As String 'This will be our "Query"
Dim strUserDB As String 'This get sets to the email field in our database.
Dim strPassDB As String 'Same as above just for the password
Dim blnUserFound As Boolean 'I will be using a "DO" loop so I will use
'this as my condition
DBConn.Open("Provider = Microsoft.Jet.OLEDB.4.0;" & _
"Data Source = '" & Application.StartupPath & "\UserDetails2000.mdb'")
'The inverted comas in the dataOuce statement as itt keeps the location of your
'file as one string.
User.Open("tblUserDetails", DBConn, ADODB.CursorTypeEnum.adOpenStatic, ADODB.LockTypeEnum.adLockOptimistic)
'This is my table 'This is my connection 'These are some settings
blnUserFound = False
Login = False
Username = "User = '" & txtEmail.Text & "'" 'This tells the database to find the email field
'Equivilent to what was entered in the textbox
Do
User.Find(Username) 'This is the full statement that sends my 'Query' to the record set
If User.BOF = False And User.EOF = False Then
'BOF = Begining of file, EOF = End of file, it tests whether the database has
'reached its sentinal value, if it hasent then the username has been found, If it has,
'the username has been found.
strUserDB = User.Fields("Email").Value.ToString
'"Email" is my table field. I am setting strUserDB to the username field of my table
strPassDB = User.Fields("Password").Value.ToString
If strUserDB <> txtEmail.Text Then
User.MoveNext()
'This IF statement handles different CASE usernames, Example, admin and AdMiN
'We use this if statement to differentiate between different CASE letters
Else
blnUserFound = True
If strPassDB = txtPassword.Text Then
User.Close()
DBConn.Close()
Return True
Else
LoginError = "Invalid Password"
User.Close()
DBConn.Close()
Return False
End If
End If
Else
LoginError = "Invalid Username"
User.Close()
DBConn.Close()
Return False
End If
Loop Until blnUserFound = True
LoginError = "Invalid Username"
User.Close()
DBConn.Close()
Return False
End Function
Private Sub btnLogin_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles btnLogin.Click
If Login() = True Then
MessageBox.Show("Login Succesful", "Login Status")
Else
MessageBox.Show(LoginError, "Login Status")
End If
End Sub
End Class
Verify that tblUserDetails contains a column named User.
Maybe User is also a reserved keyword in Access so try setting Username as:
Username = "[User] = '" & txtEmail.Text & "'"
My program has been using:
Dim DLLink1 As String
DLLink1 = Trim(TextBox2.Text)
Dim DownloadDirectory1 As String
DownloadDirectory1 = Trim(TextBox4.Text)
Try
Button3.Enabled = False
' My.Computer.Network.DownloadFile(DLLink1, (DownloadDirectory1 + "/UpdatedClient.zip"))
Dim HttpReq As HttpWebRequest = DirectCast(WebRequest.Create(DLLink1), HttpWebRequest)
Using HttpResponse As HttpWebResponse = DirectCast(HttpReq.GetResponse(), HttpWebResponse)
Using Reader As New BinaryReader(HttpResponse.GetResponseStream())
Dim RdByte As Byte() = Reader.ReadBytes(1 * 1024 * 1024 * 10)
Using FStream As New FileStream(DownloadDirectory1 + "/UpdatedClient.zip", FileMode.Create)
FStream.Write(RdByte, 0, RdByte.Length)
End Using
End Using
End Using
Finally
MsgBox("Finished Download.")
Button3.Enabled = True
Label4.Visible = True
I tried this previously, and it didn't work at all:
My.Computer.Network.DownloadFile(DLLink1, (DownloadDirectory1 + "/UpdatedClient.zip"))
The website requires you to be logged in, so I made a spare account for the program:
WebBrowser1.Navigate("http://www.mpgh.net/forum/admincp/")
Timer1.Start()
Button2.Enabled = False
Then
WebBrowser1.Document.GetElementById("vb_login_username").SetAttribute("value", "AutoUpdaterAccount")
WebBrowser1.Document.GetElementById("vb_login_password").SetAttribute("value", "password")
Dim allelements As HtmlElementCollection = WebBrowser1.Document.All
For Each webpageelement As HtmlElement In allelements
If webpageelement.GetAttribute("type") = "submit" Then
webpageelement.InvokeMember("click")
Timer1.Stop()
Label5.Text = "Authorized."
Button2.Enabled = True
So now you're logged into the account, on the website, but when the code above to download runs, it downloads a zip, but it's corrupted. So I opened it with notepad++ and this is what I get (Does this mean it didn't login for the download, and it only logged in with the webbrowser and they aren't linked? Or something? Like My firefox logins aren't linked with chrome?:
The code is huge, it's like a HTML coding. Here is the link to a online notepad I put it on:
http://shrib.com/nCOucdfL
Another thing, a webbrowser can't be showing on the program, it can be on the outside not showing, like I did with the login. They also can't click the save button like on a normal web browser when a window pops up, I want it to download automatically to where they set it using a button which sets the directory as DownloadDirectory1
It must be your lucky day because today I woke up and decided that I would like to help you with your cause. I first tried to get the download to work with the web browser control but unfortunately I am sure this is not possible without extending the web browser control and we don't want to do that today.
As I mentioned in the comments, the only way I really know that this is possible (without user interaction) is to log in via the HttpWebRequest method. It's pretty tricky stuff. Definitely not for beginners.
Now I must admit that this isn't the cleanest, most "proper" and user-friendly code around, so if anyone wants to suggest a better way to do things, I am all ears.
I suggest you test this first before you incorporate it into your existing app. Just create a new vb.net app and replace all of the code in Form1 with the code below. You will have to update the usernamehere and passwordhere strings with your real username and password. Also, the file is saving to C:\file.rar by default so you can change this path if you want. This code completely removes the need for the web browser control (unless you are using it for something else) so most likely you can remove that from your real application once you incorporate this properly:
Imports System.Net
Imports System.IO
Imports System.Text
Public Class Form1
Private Const gsUserAgent As String = "Mozilla/5.0 (Windows NT 6.1; WOW64; rv:35.0) Gecko/20100101 Firefox/35.0"
Const sUsername As String = "usernamehere"
Const sPassword As String = "passwordhere"
Const sMainURL As String = "http://www.mpgh.net/"
Const sCheckLoginURL As String = "http://www.mpgh.net/forum/login.php?do=login"
Const sDownloadURL As String = "http://www.mpgh.net/forum/attachment.php?attachmentid=266579&d=1417312178"
Const sCookieLoggedInMessage As String = "mpgh_imloggedin=yes"
Dim oCookieCollection As CookieCollection = Nothing
Dim sSaveFile As String = "c:\file.rar"
Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
StartScrape()
End Sub
Private Sub StartScrape()
Try
Dim bContinue As Boolean = True
Dim sPostData(15) As String
sPostData(0) = UrlEncode("vb_login_username")
sPostData(1) = UrlEncode(sUsername)
sPostData(2) = UrlEncode("vb_login_password")
sPostData(3) = UrlEncode(sPassword)
sPostData(4) = UrlEncode("vb_login_password_hint")
sPostData(5) = UrlEncode("Password")
sPostData(6) = UrlEncode("s")
sPostData(7) = UrlEncode("")
sPostData(8) = UrlEncode("securitytoken")
sPostData(9) = UrlEncode("guest")
sPostData(10) = UrlEncode("do")
sPostData(11) = UrlEncode("login")
sPostData(12) = UrlEncode("vb_login_md5password")
sPostData(13) = UrlEncode("")
sPostData(14) = UrlEncode("vb_login_md5password_utf")
sPostData(15) = UrlEncode("")
If GetMethod(sMainURL) = True Then
If SetMethod(sCheckLoginURL, sPostData, sMainURL) = True Then
' Login successful
If DownloadMethod(sDownloadURL, sMainURL) = True Then
MessageBox.Show("File downloaded successfully")
Else
MessageBox.Show("Error downloading file")
End If
End If
End If
Catch ex As Exception
MessageBox.Show(ex.Message, "Error", MessageBoxButtons.OK, MessageBoxIcon.Error)
End Try
End Sub
Private Function GetMethod(ByVal sPage As String) As Boolean
Dim req As HttpWebRequest
Dim resp As HttpWebResponse
Dim stw As StreamReader
Dim bReturn As Boolean = True
Try
req = HttpWebRequest.Create(sPage)
req.Method = "GET"
req.AllowAutoRedirect = False
req.UserAgent = gsUserAgent
req.Accept = "text/xml,application/xml,application/xhtml+xml,text/html;q=0.9,text/plain;q=0.8,image/png,*/*;q=0.5"
req.Headers.Add("Accept-Language", "en-us,en;q=0.5")
req.Headers.Add("Accept-Charset", "ISO-8859-1,utf-8;q=0.7,*;q=0.7")
req.Headers.Add("Keep-Alive", "300")
req.KeepAlive = True
resp = req.GetResponse ' Get the response from the server
If req.HaveResponse Then
' Save the cookie info if applicable
SaveCookies(resp.Headers("Set-Cookie"))
resp = req.GetResponse ' Get the response from the server
stw = New StreamReader(resp.GetResponseStream)
stw.ReadToEnd() ' Read the response from the server, but we do not save it
Else
MessageBox.Show("No response received from host " & sPage, "Error", MessageBoxButtons.OK, MessageBoxIcon.Error)
bReturn = False
End If
Catch exc As WebException
MessageBox.Show("Network Error: " & exc.Message.ToString & " Status Code: " & exc.Status.ToString & " from " & sPage, "Error", MessageBoxButtons.OK, MessageBoxIcon.Error)
bReturn = False
End Try
Return bReturn
End Function
Private Function SetMethod(ByVal sPage As String, ByVal sPostData() As String, sReferer As String) As Boolean
Dim bReturn As Boolean = False
Dim req As HttpWebRequest
Dim resp As HttpWebResponse
Dim str As StreamWriter
Dim sPostDataValue As String = ""
Try
req = HttpWebRequest.Create(sPage)
req.Method = "POST"
req.UserAgent = gsUserAgent
req.Accept = "application/x-shockwave-flash,text/xml,application/xml,application/xhtml+xml,text/html;q=0.9,text/plain;q=0.8,image/png,*/*;q=0.5"
req.Headers.Add("Accept-Language", "en-us,en;q=0.5")
req.Headers.Add("Accept-Charset", "ISO-8859-1,utf-8;q=0.7,*;q=0.7")
req.Referer = sReferer
req.ContentType = "application/x-www-form-urlencoded"
req.Headers.Add("Pragma", "no-cache")
req.Headers.Add("Keep-Alive", "300")
If oCookieCollection IsNot Nothing Then
' Pass cookie info from the login page
req.CookieContainer = SetCookieContainer(sPage)
End If
str = New StreamWriter(req.GetRequestStream)
If sPostData.Count Mod 2 = 0 Then
' There is an even number of post names and values
For i As Int32 = 0 To sPostData.Count - 1 Step 2
' Put the post data together into one string
sPostDataValue &= sPostData(i) & "=" & sPostData(i + 1) & "&"
Next i
sPostDataValue = sPostDataValue.Substring(0, sPostDataValue.Length - 1) ' This will remove the extra "&" at the end that was added from the for loop above
' Post the data to the server
str.Write(sPostDataValue)
str.Close()
' Get the response
resp = req.GetResponse
If req.HaveResponse Then
If resp.Headers("Set-Cookie").IndexOf(sCookieLoggedInMessage) > -1 Then
' Save the cookie info
SaveCookies(resp.Headers("Set-Cookie"))
bReturn = True
Else
MessageBox.Show("The email or password you entered are incorrect." & vbCrLf & vbCrLf & "Please try again.", "Unable to log in", MessageBoxButtons.OK, MessageBoxIcon.Exclamation)
bReturn = False
End If
Else
' This should probably never happen.. but if it does, we give a message
MessageBox.Show("The email or password you entered are incorrect." & vbCrLf & vbCrLf & "Please try again.", "Unable to log in", MessageBoxButtons.OK, MessageBoxIcon.Exclamation)
bReturn = False
End If
Else
' Did not specify the correct amount of parameters so we cannot continue
MessageBox.Show("POST error. Did not supply the correct amount of post data for " & sPage, "Error", MessageBoxButtons.OK, MessageBoxIcon.Error)
bReturn = False
End If
Catch ex As Exception
MessageBox.Show("POST error. " & ex.Message, "Error", MessageBoxButtons.OK, MessageBoxIcon.Error)
bReturn = False
End Try
Return bReturn
End Function
Private Function DownloadMethod(ByVal sPage As String, sReferer As String) As Boolean
Dim req As HttpWebRequest
Dim bReturn As Boolean = False
Try
req = HttpWebRequest.Create(sPage)
req.Method = "GET"
req.AllowAutoRedirect = False
req.UserAgent = gsUserAgent
req.Accept = "text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8"
req.Headers.Add("Accept-Language", "en-US,en;q=0.5")
req.Headers.Add("Accept-Encoding", "gzip, deflate")
req.Headers.Add("Keep-Alive", "300")
req.KeepAlive = True
If oCookieCollection IsNot Nothing Then
' Set cookie info so that we continue to be logged in
req.CookieContainer = SetCookieContainer(sPage)
End If
' Save file to disk
Using oResponse As System.Net.WebResponse = CType(req.GetResponse, System.Net.WebResponse)
Using responseStream As IO.Stream = oResponse.GetResponseStream
Using fs As New IO.FileStream(sSaveFile, FileMode.Create, FileAccess.Write)
Dim buffer(2047) As Byte
Dim read As Integer
Do
read = responseStream.Read(buffer, 0, buffer.Length)
fs.Write(buffer, 0, read)
Loop Until read = 0
responseStream.Close()
fs.Flush()
fs.Close()
End Using
responseStream.Close()
End Using
oResponse.Close()
End Using
bReturn = True
Catch exc As WebException
MessageBox.Show("Network Error: " & exc.Message.ToString & " Status Code: " & exc.Status.ToString & " from " & sPage, "Error", MessageBoxButtons.OK, MessageBoxIcon.Error)
bReturn = False
End Try
Return bReturn
End Function
Private Function SetCookieContainer(sPage As String) As System.Net.CookieContainer
Dim oCookieContainerObject As New System.Net.CookieContainer
Dim oCookie As System.Net.Cookie
For c As Int32 = 0 To oCookieCollection.Count - 1
If IsDate(oCookieCollection(c).Value) = True Then
' Fix dates as they seem to cause errors/problems
oCookieCollection(c).Value = Format(CDate(oCookieCollection(c).Value), "dd-MMM-yyyy hh:mm:ss")
End If
oCookie = New System.Net.Cookie
oCookie.Name = oCookieCollection(c).Name
oCookie.Value = oCookieCollection(c).Value
oCookie.Domain = New Uri(sPage).Host
oCookie.Secure = False
oCookieContainerObject.Add(oCookie)
Next
Return oCookieContainerObject
End Function
Private Sub SaveCookies(sCookieString As String)
Dim sCookieStrings() As String = sCookieString.Trim.Replace(" HttpOnly,", "").Replace(" HttpOnly", "").Replace(" domain=.mpgh.net,", "").Split(";".ToCharArray())
oCookieCollection = New CookieCollection
For Each sCookie As String In sCookieStrings
If sCookie.Trim <> "" Then
Dim sName As String = sCookie.Trim().Split("=".ToCharArray())(0)
Dim sValue As String = sCookie.Trim().Split("=".ToCharArray())(1)
oCookieCollection.Add(New Cookie(sName, sValue))
End If
Next
End Sub
Private Function UrlEncode(ByRef URLText As String) As String
Dim AscCode As Integer
Dim EncText As String = ""
Dim bStr() As Byte = Encoding.ASCII.GetBytes(URLText)
Try
For i As Long = 0 To UBound(bStr)
AscCode = bStr(i)
Select Case AscCode
Case 48 To 57, 65 To 90, 97 To 122, 46, 95
EncText = EncText & Chr(AscCode)
Case 32
EncText = EncText & "+"
Case Else
If AscCode < 16 Then
EncText = EncText & "%0" & Hex(AscCode)
Else
EncText = EncText & "%" & Hex(AscCode)
End If
End Select
Next i
Erase bStr
Catch ex As WebException
MessageBox.Show(ex.Message, "Error", MessageBoxButtons.OK, MessageBoxIcon.Error)
End Try
Return EncText
End Function
End Class
I have an MS Access database which now requires me to 'attach' documents to it. My intention is to store the documents on Google Drive and have a link on the database for users to retrieve the documents.
As there are many users spread through different cities, it is not practical to require them to have synced Google Drive folders. All the users will need the ability to upload to the database/GD so my intention is to have a separate Google account for the database - with its own login details.
example:
User clicks button to upload file
Save as dialog box appears and user selects file
Database logs into its Google Drive and uploads selected file
Lots of problems with this though, the main one being that Google Drive does not support VBA.
If the user is logged into their own Gmail account, that will probably be another issue.
I came across this code for vb.net on another site.
Imports System
Imports System.Diagnostics
Imports DotNetOpenAuth.OAuth2
Imports Google.Apis.Authentication.OAuth2
Imports Google.Apis.Authentication.OAuth2.DotNetOpenAuth
Imports Google.Apis.Drive.v2
Imports Google.Apis.Drive.v2.Data
Imports Google.Apis.Util
Imports Google.Apis.Services
Namespace GoogleDriveSamples
Class DriveCommandLineSample
Shared Sub Main(ByVal args As String)
Dim CLIENT_ID As [String] = "YOUR_CLIENT_ID"
Dim CLIENT_SECRET As [String] = "YOUR_CLIENT_SECRET"
'' Register the authenticator and create the service
Dim provider = New NativeApplicationClient(GoogleAuthenticationServer.Description, CLIENT_ID, CLIENT_SECRET)
Dim auth = New OAuth2Authenticator(Of NativeApplicationClient)(provider, GetAuthorization)
Dim service = New DriveService(New BaseClientService.Initializer() With { _
.Authenticator = auth _
})
Dim body As New File()
body.Title = "My document"
body.Description = "A test document"
body.MimeType = "text/plain"
Dim byteArray As Byte() = System.IO.File.ReadAllBytes("document.txt")
Dim stream As New System.IO.MemoryStream(byteArray)
Dim request As FilesResource.InsertMediaUpload = service.Files.Insert(body, stream, "text/plain")
request.Upload()
Dim file As File = request.ResponseBody
Console.WriteLine("File id: " + file.Id)
Console.WriteLine("Press Enter to end this process.")
Console.ReadLine()
End Sub
Private Shared Function GetAuthorization(ByVal arg As NativeApplicationClient) As IAuthorizationState
' Get the auth URL:
Dim state As IAuthorizationState = New AuthorizationState( New () {DriveService.Scopes.Drive.GetStringValue()})
state.Callback = New Uri(NativeApplicationClient.OutOfBandCallbackUrl)
Dim authUri As Uri = arg.RequestUserAuthorization(state)
' Request authorization from the user (by opening a browser window):
Process.Start(authUri.ToString())
Console.Write(" Authorization Code: ")
Dim authCode As String = Console.ReadLine()
Console.WriteLine()
' Retrieve the access token by using the authorization code:
Return arg.ProcessUserAuthorization(authCode, state)
End Function
End Class
End Namespace
It was suggested that the IE library could be utilised to log into the Google Drive and the API calls made from the above to upload. I don't know how to do this. Somewhere else it was mentioned that a 'COM wrapper' may be suitable. I don't have experience with any coding other than VBA (self taught) so am struggling to understand what the next step should be.
If anyone has done something similar or can offer any advice, I would be grateful to hear from you.
This thread might be dead now but if you are working with forms in your database and the user needs to be attaching the files to a particular record displayed in a form with a unique identification number then this is definitely possible but you would have to do it in an external application written in .NET I can provide you with the necessary code to get you started, vb.net is very similar to VBA.
What you would need to do is create a windows form project and add references to Microsoft access core dll and download the nugget package for google drive api from nugget.
Imports Google
Imports Google.Apis.Services
Imports Google.Apis.Drive.v2
Imports Google.Apis.Auth.OAuth2
Imports Google.Apis.Drive.v2.Data
Imports System.Threading
Public Class GoogleDriveAuth
Public Shared Function GetAuthentication() As DriveService
Dim ClientIDString As String = "Your Client ID"
Dim ClientSecretString As String = "Your Client Secret"
Dim ApplicationNameString As String = "Your Application Name"
Dim secrets = New ClientSecrets()
secrets.ClientId = ClientIDString
secrets.ClientSecret = ClientSecretString
Dim scope = New List(Of String)
scope.Add(DriveService.Scope.Drive)
Dim credential = GoogleWebAuthorizationBroker.AuthorizeAsync(secrets, scope, "user", CancellationToken.None).Result()
Dim initializer = New BaseClientService.Initializer
initializer.HttpClientInitializer = credential
initializer.ApplicationName = ApplicationNameString
Dim Service = New DriveService(initializer)
Return Service
End Function
End Class
This code will authorise your drive service then you create a Public Shared Service As DriveService under your imports that can be used from any sub or function then call this function on your form load event like
Service = GoogleDriveAuth.GetAuthentication
Add a reference to your project to Microsoft Access 12.0 Object Library or whatever version you have
Then this piece of code will look at the form you want to get the value of the record no from and upload a file to your choice of folder
Private Sub UploadAttachments()
Dim NumberExtracted As String
Dim oAccess As Microsoft.Office.Interop.Access.Application = Nothing
Dim connectedToAccess As Boolean = False
Dim SelectedFolderIdent As String = "Your Upload Folder ID"
Dim CreatedFolderIdent As String
Dim tryToConnect As Boolean = True
Dim oForm As Microsoft.Office.Interop.Access.Form
Dim oCtls As Microsoft.Office.Interop.Access.Controls
Dim oCtl As Microsoft.Office.Interop.Access.Control
Dim sForm As String 'name of form to show
sForm = "Your Form Name"
Try
While tryToConnect
Try
' See if can connect to a running Access instance
oAccess = CType(Marshal.GetActiveObject("Access.Application"), Microsoft.Office.Interop.Access.Application)
connectedToAccess = True
Catch ex As Exception
Try
' If couldn't connect to running instance of Access try to start a running Access instance And get an updated version of the database
oAccess = CType(CreateObject("Access.Application"), Microsoft.Office.Interop.Access.Application)
oAccess.Visible = True
oAccess.OpenCurrentDatabase("Your Database Path", False)
connectedToAccess = True
Catch ex2 As Exception
Dim res As DialogResult = MessageBox.Show("COULD NOT CONNECT TO OR START THE DATABASE" & vbNewLine & ex2.Message, "Warning", MessageBoxButtons.AbortRetryIgnore, MessageBoxIcon.Warning)
If res = System.Windows.Forms.DialogResult.Abort Then
Exit Sub
End If
If res = System.Windows.Forms.DialogResult.Ignore Then
tryToConnect = False
End If
End Try
End Try
' We have connected successfully; stop trying
tryToConnect = False
End While
' Start a new instance of Access for Automation:
' Make sure Access is visible:
If Not oAccess.Visible Then oAccess.Visible = True
' For Each oForm In oAccess.Forms
' oAccess.DoCmd.Close(ObjectType:=Microsoft.Office.Interop.Access.AcObjectType.acForm, ObjectName:=oForm.Name, Save:=Microsoft.Office.Interop.Access.AcCloseSave.acSaveNo)
' Next
' If Not oForm Is Nothing Then
' System.Runtime.InteropServices.Marshal.ReleaseComObject(oForm)
' End If
' oForm = Nothing
' Select the form name in the database window and give focus
' to the database window:
' oAccess.DoCmd.SelectObject(ObjectType:=Microsoft.Office.Interop.Access.AcObjectType.acForm, ObjectName:=sForm, InDatabaseWindow:=True)
' Show the form:
' oAccess.DoCmd.OpenForm(FormName:=sForm, View:=Microsoft.Office.Interop.Access.AcFormView.acNormal)
' Use Controls collection to edit the form:
oForm = oAccess.Forms(sForm)
oCtls = oForm.Controls
oCtl = oCtls.Item("The Name Of The Control Where The Id Number Is On The Form")
oCtl.Enabled = True
' oCtl.SetFocus()
NumberExtracted = oCtl.Value
System.Runtime.InteropServices.Marshal.ReleaseComObject(oCtl)
oCtl = Nothing
' Hide the Database Window:
' oAccess.DoCmd.SelectObject(ObjectType:=Microsoft.Office.Interop.Access.AcObjectType.acForm, ObjectName:=sForm, InDatabaseWindow:=True)
' oAccess.RunCommand(Command:=Microsoft.Office.Interop.Access.AcCommand.acCmdWindowHide)
' Set focus back to the form:
' oForm.SetFocus()
' Release Controls and Form objects:
System.Runtime.InteropServices.Marshal.ReleaseComObject(oCtls)
oCtls = Nothing
System.Runtime.InteropServices.Marshal.ReleaseComObject(oForm)
oForm = Nothing
' Release Application object and allow Access to be closed by user:
If Not oAccess.UserControl Then oAccess.UserControl = True
System.Runtime.InteropServices.Marshal.ReleaseComObject(oAccess)
oAccess = Nothing
If NumberExtracted = Nothing Then
MsgBox("The Number Could Not Be Obtained From The Form" & vbNewLine & vbNewLine & "Please Ensure You Have The Form Open Before Trying To Upload")
Exit Sub
End If
If CheckForDuplicateFolder(SelectedFolderIdent, NumberExtracted + " - ATC") = True Then
CreatedFolderIdent = GetCreatedFolderID(NumberExtracted + " - ATC", SelectedFolderIdent)
DriveFilePickerUploader(CreatedFolderIdent)
Else
CreateNewDriveFolder(NumberExtracted + " - ATC", SelectedFolderIdent)
CreatedFolderIdent = GetCreatedFolderID(NumberExtracted + " - ATC", SelectedFolderIdent)
DriveFilePickerUploader(CreatedFolderIdent)
End If
Catch EX As Exception
MsgBox("The Number Could Not Be Obtained From The Form" & vbNewLine & vbNewLine & "Please Ensure You Have The Form Open Before Trying To Upload" & vbNewLine & vbNewLine & EX.Message)
Exit Sub
Finally
If Not oCtls Is Nothing Then
System.Runtime.InteropServices.Marshal.ReleaseComObject(oCtls)
oCtls = Nothing
End If
If Not oForm Is Nothing Then
System.Runtime.InteropServices.Marshal.ReleaseComObject(oForm)
oForm = Nothing
End If
If Not oAccess Is Nothing Then
System.Runtime.InteropServices.Marshal.ReleaseComObject(oAccess)
oAccess = Nothing
End If
End Try
End
End Sub
Check For Duplicate Folders In The Destination Upload Folder
Public Function CheckForDuplicateFolder(ByVal FolderID As String, ByVal NewFolderNameToCheck As String) As Boolean
Dim ResultToReturn As Boolean = False
Try
Dim request = Service.Files.List()
Dim requeststring As String = ("'" & FolderID & "' in parents And mimeType='application/vnd.google-apps.folder' And trashed=false")
request.Q = requeststring
Dim FileList = request.Execute()
For Each File In FileList.Items
If File.Title = NewFolderNameToCheck Then
ResultToReturn = True
End If
Next
Catch EX As Exception
MsgBox("THERE HAS BEEN AN ERROR" & EX.Message)
End Try
Return ResultToReturn
End Function
Create New Drive Folder
Public Sub CreateNewDriveFolder(ByVal DirectoryName As String, ByVal ParentFolder As String)
Try
Dim body1 = New Google.Apis.Drive.v2.Data.File
body1.Title = DirectoryName
body1.Description = "Created By Automation"
body1.MimeType = "application/vnd.google-apps.folder"
body1.Parents = New List(Of ParentReference)() From {New ParentReference() With {.Id = ParentFolder}}
Dim file1 As Google.Apis.Drive.v2.Data.File = Service.Files.Insert(body1).Execute()
Catch EX As Exception
MsgBox("THERE HAS BEEN AN ERROR" & EX.Message)
End Try
End Sub
Get The Created Folder ID
Public Function GetCreatedFolderID(ByVal FolderName As String, ByVal FolderID As String) As String
Dim ParentFolder As String
Try
Dim request = Service.Files.List()
Dim requeststring As String = ("'" & FolderID & "' in parents And mimeType='application/vnd.google-apps.folder' And title='" & FolderName & "' And trashed=false")
request.Q = requeststring
Dim Parent = request.Execute()
ParentFolder = (Parent.Items(0).Id)
Catch EX As Exception
MsgBox("THERE HAS BEEN AN ERROR" & EX.Message)
End Try
Return ParentFolder
End Function
Drive File Picker Uploader To Upload Files Selected From A File Dialog Box To The Newly Created Folder
Public Sub DriveFilePickerUploader(ByVal ParentFolderID As String)
Try
ProgressBar1.Value = 0
Dim MimeTypeToUse As String
Dim dr As DialogResult = Me.OpenFileDialog1.ShowDialog()
If (dr = System.Windows.Forms.DialogResult.OK) Then
Dim file As String
Else : Exit Sub
End If
Dim i As Integer = 0
For Each file In OpenFileDialog1.FileNames
MimeTypeToUse = GetMimeType(file)
Dim filetitle As String = (OpenFileDialog1.SafeFileNames(i))
Dim body2 = New Google.Apis.Drive.v2.Data.File
body2.Title = filetitle
body2.Description = "J-T Auto File Uploader"
body2.MimeType = MimeTypeToUse
body2.Parents = New List(Of ParentReference)() From {New ParentReference() With {.Id = ParentFolderID}}
Dim byteArray = System.IO.File.ReadAllBytes(file)
Dim stream = New System.IO.MemoryStream(byteArray)
Dim request2 = Service.Files.Insert(body2, stream, MimeTypeToUse)
request2.Upload()
Next
Catch EX As Exception
MsgBox("THERE HAS BEEN AN ERROR" & EX.Message)
End Try
End Sub
Get The Mime Type Of The Files Being Uploaded
Public Shared Function GetMimeType(ByVal file As String) As String
Dim mime As String = Nothing
Dim MaxContent As Integer = CInt(New FileInfo(file).Length)
If MaxContent > 4096 Then
MaxContent = 4096
End If
Dim fs As New FileStream(file, FileMode.Open)
Dim buf(MaxContent) As Byte
fs.Read(buf, 0, MaxContent)
fs.Close()
Dim result As Integer = FindMimeFromData(IntPtr.Zero, file, buf, MaxContent, Nothing, 0, mime, 0)
Return mime
End Function
<DllImport("urlmon.dll", CharSet:=CharSet.Auto)> _
Private Shared Function FindMimeFromData( _
ByVal pBC As IntPtr, _
<MarshalAs(UnmanagedType.LPWStr)> _
ByVal pwzUrl As String, _
<MarshalAs(UnmanagedType.LPArray, ArraySubType:=UnmanagedType.I1, SizeParamIndex:=3)> ByVal _
pBuffer As Byte(), _
ByVal cbSize As Integer, _
<MarshalAs(UnmanagedType.LPWStr)> _
ByVal pwzMimeProposed As String, _
ByVal dwMimeFlags As Integer, _
<MarshalAs(UnmanagedType.LPWStr)> _
ByRef ppwzMimeOut As String, _
ByVal dwReserved As Integer) As Integer
End Function
Hopefully this helps you make a start I am 100% convinced this is achievable as I have already done this for my manager.
This reply might be late but just wanna share one of the approach!
I have done this successfully with VBA and the demo link is here
http://www.sfdp.net/thuthuataccess/demo/democAuth.rar?attredirects=0&d=1
With this, you can upload, download or delete a file with your GoogleDrive in Access..
Just Wininet + WinHTTP enough
Dang Dinh ngoc
Vietnam
We are using digital persona for our biometrics. We can already save employee ID, employee name and assigned finger .Our problem is that we dont know how to save a fingerprint template to a database and retrieve it so that it can still be read and verified by the biometric scanner. The file extension is ".ftp" .
CODE:
Private Sub buttonRegister_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles buttonRegister.Click
'Does user already exists
Dim bUserExists As Boolean = _Users.UserExists(New UserID(textBoxUserName.Text))
' first make sure the user is created if new user
If _ActiveUser Is Nothing Or Not bUserExists Then
' initialize with supplied user name
_ActiveUser = New User(textBoxUserName.Text)
Else
' update active user if not as originally selected
If bUserExists And Not listBoxUsers.SelectedItem.ToString() = textBoxUserName.Text Then
_ActiveUser = _Users(New UserID(textBoxUserName.Text))
End If
End If
' and check if the template already exists for the assigned finger
If _ActiveUser.TemplateExists(_AssignedFinger) Then
' show message indicating template already exists for selected finger
Dim diagResult As DialogResult = MessageBox.Show(Me, [String].Format("Oops!" + ControlChars.Cr + ControlChars.Lf + "{0} has a template enrolled to his/her {1} finger." + ControlChars.Cr + ControlChars.Lf + ControlChars.Cr + ControlChars.Lf + "Shall the old template be discarded?", _ActiveUser.ID.ToString(), _Fingers(_AssignedFinger)), "Template already assigned!", MessageBoxButtons.YesNo, MessageBoxIcon.Error)
' if user selected not to overwrite, then abort
If diagResult = Windows.Forms.DialogResult.No Then
Return
End If
End If
Try
' attempt to read the template
Dim templateOpened As New DPFP.Template(File.OpenRead(textBoxTemplateFilename.Text))
' run a template duplicate check
IdentifyTemplate(templateOpened)
' remove the old template if exists
If _ActiveUser.TemplateExists(_AssignedFinger) Then
' removed from assigned finger
_ActiveUser.RemoveTemplate(_AssignedFinger)
End If
' and assign it to the user as specified
_ActiveUser.AddTemplate(templateOpened, _AssignedFinger)
' update collection
If Not _Users.UserExists(_ActiveUser.ID) Then
' update list box
listBoxUsers.Items.Add(_ActiveUser.ID.ToString())
' add user it to the user collection
_Users.AddUser(_ActiveUser)
End If
' success
UpdateEventLog([String].Format("{0}: Template successfully assigned to {1} finger.", _ActiveUser.ID.ToString(), _AssignedFinger.ToString()))
' turn off groupbox
groupAddTemplate.Visible = False
listBoxUsers.SelectedItem = _ActiveUser.ID.ToString()
' sync gui
_syncUI()
' view user
_syncViewUser()
Catch Err As DPFP.Error.SDKException
' log message
UpdateEventLog(Err.ToString())
System.Diagnostics.Trace.WriteLine(Err.ToString())
Catch Err As System.IO.FileNotFoundException
' log message
UpdateEventLog("Template file not found or is inaccessible.")
System.Diagnostics.Trace.WriteLine(Err.ToString())
Catch Err As Exception
' log message
UpdateEventLog(Err.ToString())
System.Diagnostics.Trace.WriteLine(Err.ToString())
End Try
Using conn As New MySqlConnection("Server = localhost; Username= root; Password =; Database = vb")
Using cmd
With cmd
MsgBox("Connection Established")
.Connection = conn
.Parameters.Clear()
'Create Insert Query
.CommandText = "INSERT INTO employees(UserID, Name, Finger) VALUES (#iID, #iName, #iFinger)"
.Parameters.Add(New MySqlParameter("#iID", ID.Text))
.Parameters.Add(New MySqlParameter("#iName", textBoxUserName.Text))
.Parameters.Add(New MySqlParameter("#iFinger", comboBoxAssignedFinger.Text))
End With
Try
'Open Connection and Execute Query
conn.Open()
cmd.ExecuteNonQuery()
Catch ex As MySqlException
MsgBox(ex.Message.ToString())
End Try
End Using
End Using
i know that this is an old post but here are code blocks that might help...
IN SAVING I USED THIS
For Each template As DPFP.Template In Data.Templates
If Not template Is Nothing Then
cmd = New MySqlCommand("INSERT INTO employeefp " +
"SET No=#No, " +
"FP=#FP " +
" ", conn)
cmd.Parameters.Add(New MySqlParameter("#No", txtEmpNo.Text))
cmd.Parameters.Add(New MySqlParameter("#FP", template.Bytes))
cmd.ExecuteNonQuery()
End If
Next
IN VERIFYING FROM THE DB I USED THIS
WHEN FORM IS LOADED I FETCH ALL THE FINGER PRINTS
Dim cmd As New MySqlCommand("SELECT * FROM employeefp ", conn)
Dim rdr As MySqlDataReader = cmd.ExecuteReader()
While (rdr.Read())
Dim MemStream As IO.MemoryStream
Dim fpBytes As Byte()
fpBytes = rdr("FP")
MemStream = New IO.MemoryStream(fpBytes)
Dim templa8 As DPFP.Template = New DPFP.Template()
templa8.DeSerialize(MemStream)
Dim tmpObj As New AppData
tmpObj.No = rdr("No").ToString()
tmpObj.Template = templa8
FPList.Add(tmpObj)
End While
NOTE : Dim FPList As List(Of AppData) = New List(Of AppData) //you can find the definition of this in the SDK i just added Template (contains one print) aside from the existing Templates(contains many print)
COMPARE THE CURRENT SAMPLE FROM THE MACHINE
Sub OnComplete(ByVal Control As Object, ByVal FeatureSet As DPFP.FeatureSet, ByRef EventHandlerStatus As DPFP.Gui.EventHandlerStatus) Handles VerificationControl.OnComplete
Dim printFound As Boolean = False
VerifiedFPData = New AppData
Try
For Each FPData As AppData In FPList
Dim tmplateData As New DPFP.Template
tmplateData = FPData.Template
Dim compareTo As New DPFP.FeatureSet
compareTo = FeatureSet
Dim ver As New DPFP.Verification.Verification()
Dim res As New DPFP.Verification.Verification.Result()
If Not tmplateData Is Nothing Then
ver.Verify(FeatureSet, tmplateData, res)
If res.Verified Then
EventHandlerStatus = DPFP.Gui.EventHandlerStatus.Success
printFound = True
VerifiedFPData = FPData
Exit For ' success
End If
End If
Next
Catch ex As Exception
MessageBox.Show("verification error")
End Try
If printFound Then
//TO DO
Else
EventHandlerStatus = DPFP.Gui.EventHandlerStatus.Failure
// TODO
End If
End Sub
hope it helps someone :)
There are some missing codes from the answer above. The code of the class appdata is missing.These code is error without declaring first the tmpObj in the class AppData. Dim tmpObj As New AppData
tmpObj.No = rdr("No").ToString()
tmpObj.Template = templa8
FPList.Add(tmpObj)