I have a mechanism that downloads attachments from email messages sent into an inbox to a folder for processing by another service.
Originally this was done using some VBA that was triggered by a rule in Outlook. This wasn't build with large amounts of information going in originally however it has got to the point now that lots of data is being passed through and it is causing me headaches using this Outlook VBA and SSIS Package combination.
Therefore I am working on a new version built entirely in VB .NET, this obviously will mean its more robust and a lot easier to debug problems.
I have started using the EWS API and have managed to successfully connect to the Exchange and I am able to read the relevant messages and store their Subject etc. to variables.
I am struggling however to find ANY documentation / help regarding downloading of attachements with EWS with VB .NET code.
Everything seems to be in C# and I unfortunately have no experience with this. I am totally open to 3rd Party Solutions that may need to be purchased or even pointed in the right direction of a book or documentation, this is not being done on a shoe string and is quite important.
Try converters between C# and VB.
Regarding EWS, many VB examples contains "Exchange Web Services .NET". The same examples are in C# and VB
Hopefully this will get you started in the right direction. NOTE: I have not had a chance to test this VB code, since I do not have access to an Exchange 2007 server from home (as far as I know). However, I wrote this code carefully, basing it on C# code that I know works, because I used it at my workplace. See this link: http://www.sqlteam.com/forums/topic.asp?TOPIC_ID=105257. And this one: https://social.msdn.microsoft.com/Forums/sqlserver/en-US/dd2b465b-b1d2-4c0d-82ec-c36c6c482d5d/populating-sql-server-from-emails?forum=sqltools
FURTHER NOTE: This code will DELETE each email after saving the attachments from it. I think it will be a hard delete as well. In other words, you won't be able to pull the emails back out of the Deleted Items folder. You have been warned.
(It is possible to just mark each email as read instead of deleting it, but I don't have time to write the code for that just now. Hopefully this will be enough for your needs. If you still need this question answered.)
Namespace StephenGTuggy.Examples.SaveEWS2007Attachments
Public Module EWS2007ExampleMain
Enum AuthenticationMethod
Windows
Basic
End Enum
Private Const sUserName As String = "SampleUserName"
Private Const sPassword As String = "SamplePassword1"
Private Const sDomain As String = "mycompany.com"
Private Const eAuthenticationMethod As AuthenticationMethod = AuthenticationMethod.Basic
Private Const sEWS_URL As String = "https://mailserver.mycompany.com/EWS/Exchange.asmx"
'Private Const sEmailSender As String = "SampleUserName2#SomeOtherCompany.com"
Private Const sSaveAttachmentsToDirectory As String = "C:\"
Public Sub Main()
' Set up credentials to use to connect to the Exchange server.
Dim nc As System.Net.NetworkCredential = Nothing
Select Case eAuthenticationMethod
Case AuthenticationMethod.Windows
nc = System.Net.CredentialCache.DefaultNetworkCredentials
Case Else
nc = New System.Net.NetworkCredential(sUserName, sPassword, sDomain)
End Select
' Now bind to Exchange.
Dim esb As New ExchangeWebServices.ExchangeServiceBinding
esb.Url = sEWS_URL
esb.Credentials = nc
' Main code....
Dim findItemRequest As New ExchangeWebServices.FindItemType
findItemRequest.Traversal = ExchangeWebServices.ItemQueryTraversalType.Shallow
' Define which item properties Exchange should return for each email.
Dim itemProperties As New ExchangeWebServices.ItemResponseShapeType
itemProperties.BaseShape = ExchangeWebServices.DefaultShapeNamesType.AllProperties
findItemRequest.ItemShape = itemProperties
' Identify which folders to search to find items.
Dim folderIDInbox As New ExchangeWebServices.DistinguishedFolderIdType
folderIDInbox.Id = ExchangeWebServices.DistinguishedFolderIdNameType.inbox
Dim folderIDArray As ExchangeWebServices.DistinguishedFolderIdType() = {folderIDInbox}
findItemRequest.ParentFolderIds = folderIDArray
' Limit result set to unread emails only.
Dim restriction As New ExchangeWebServices.RestrictionType
Dim isEqualTo As New ExchangeWebServices.IsEqualToType
Dim pathToFieldType As New PathToUnindexedFieldType
pathToFieldType.FieldURI = ExchangeWebServices.UnindexedFieldURIType.messageIsRead '.messageFrom
Dim constantType As New ExchangeWebServices.FieldURIOrConstantType
Dim constantValueType As New ExchangeWebServices.ConstantValueType
constantValueType.Value = "0" 'sEmailSender
constantType.Item = constantValueType
isEqualTo.Item = pathToFieldType
isEqualTo.FieldURIOrConstant = constantType
restriction.Item = isEqualTo
findItemRequest.Restriction = restriction
' Send the request to Exchange and get the response back.
System.Diagnostics.Trace.TraceInformation("Sending FindItem request....")
Dim findItemResponse As ExchangeWebServices.FindItemResponseType = esb.FindItem(findItemRequest)
System.Diagnostics.Trace.TraceInformation("Received response to FindItem request.")
' Process response from Exchange server.
Dim folder As ExchangeWebServices.FindItemResponseMessageType = _
CType(findItemResponse.ResponseMessages.Items(0), ExchangeWebServices.FindItemResponseMessageType)
Dim folderContents As ExchangeWebServices.ArrayOfRealItemsType = _
CType(folder.RootFolder.Item, ExchangeWebServices.ArrayOfRealItemsType)
Dim items As ExchangeWebServices.ItemType() = folderContents.Items
For Each curItem As ExchangeWebServices.ItemType In items
Dim iAttCount As Integer = GetFileAttachmentsCount(esb, curItem.ItemId)
System.Diagnostics.Trace.TraceInformation("Subject: {0} DisplayTo: {1} DateTimeReceived: {2} ItemClass: {3} AttachmentCount: {4}", _
curItem.Subject.Trim(), _
curItem.DisplayTo.Trim(), _
curItem.DateTimeReceived.TimeOfDay.ToString(), _
curItem.ItemClass.Trim(), _
iAttCount)
If iAttCount > 0 Then
GetAttachmentsOnItem(esb, curItem.ItemId, sSaveAttachmentsToDirectory)
If Not MarkItemAsProcessed(esb, curItem.ItemId) Then
System.Diagnostics.Trace.TraceError("Unable to mark email as processed.")
End If
End If
Next
System.Diagnostics.Trace.TraceInformation("Finished processing emails and attachments.")
End Sub
Function GetFileAttachmentsCount(binding As ExchangeWebServices.ExchangeServiceBinding, _
id As ExchangeWebServices.ItemIdType) As Integer
Dim iAttachmentCount As Integer = 0
' Use GetItem on the Id to get the Attachments collection.
Dim getItemRequest As New ExchangeWebServices.GetItemType
getItemRequest.ItemIds = New ExchangeWebServices.ItemIdType() {id}
getItemRequest.ItemShape = New ExchangeWebServices.ItemResponseShapeType
getItemRequest.ItemShape.BaseShape = ExchangeWebServices.DefaultShapeNamesType.AllProperties
Dim hasAttachPath As New ExchangeWebServices.PathToUnindexedFieldType
hasAttachPath.FieldURI = ExchangeWebServices.UnindexedFieldURIType.itemHasAttachments
Dim attachmentsPath As New ExchangeWebServices.PathToUnindexedFieldType
attachmentsPath.FieldURI = ExchangeWebServices.UnindexedFieldURIType.itemAttachments
' Add additional properties?
getItemRequest.ItemShape.AdditionalProperties = New ExchangeWebServices.BasePathToElementType() { _
hasAttachPath, attachmentsPath}
Dim getItemResponse As ExchangeWebServices.GetItemResponseType = binding.GetItem(getItemRequest)
Dim getItemResponseMessage As ExchangeWebServices.ItemInfoResponseMessageType = TryCast( _
getItemResponse.ResponseMessages.Items(0), ExchangeWebServices.ItemInfoResponseMessageType)
If getItemResponseMessage.ResponseCode = ExchangeWebServices.ResponseCodeType.NoError Then
Dim item As ExchangeWebServices.ItemType = getItemResponseMessage.Items.Items(0)
' Don't rely on HasAttachments -- it does not mean what you think it would.
If (item.Attachments IsNot Nothing) AndAlso (item.Attachments.Length > 0) Then
For attachmentIndex As Integer = 0 To item.Attachments.Length - 1
Dim almostAnAttachment As ExchangeWebServices.FileAttachmentType = TryCast( _
item.Attachments(attachmentIndex), ExchangeWebServices.FileAttachmentType)
If almostAnAttachment IsNot Nothing Then
iAttachmentCount = iAttachmentCount + 1
End If
Next
End If
End If
Return iAttachmentCount
End Function
Function MarkItemAsProcessed(esb As ExchangeWebServices.ExchangeServiceBinding, _
id As ExchangeWebServices.ItemIdType) As Boolean
Dim bReturn As Boolean = False
' Create the DeleteItem request.
Dim dit As New ExchangeWebServices.DeleteItemType
dit.ItemIds = New ExchangeWebServices.BaseItemIdType() {id}
' Delete the message.
Dim diResponse As ExchangeWebServices.DeleteItemResponseType = esb.DeleteItem(dit)
' Check the result.
If (diResponse.ResponseMessages.Items.Length > 0) AndAlso _
(diResponse.ResponseMessages.Items(0).ResponseClass = _
ExchangeWebServices.ResponseClassType.Success) Then
bReturn = True
End If
Return bReturn
End Function
Sub GetAttachmentsOnItem(binding As ExchangeWebServices.ExchangeServiceBinding, _
id As ExchangeWebServices.ItemIdType, _
destinationPath As String)
' STEP 1: We need to call GetItem on the Id so that we can get the Attachments collection back.
Dim getItemRequest As New ExchangeWebServices.GetItemType
getItemRequest.ItemIds = New ExchangeWebServices.ItemIdType() {id}
getItemRequest.ItemShape = New ExchangeWebServices.ItemResponseShapeType
' For this example, all we really need is the HasAttachments property and the Attachment collection.
' As such, let's just request those properties to reduce network traffic.
getItemRequest.ItemShape.BaseShape = ExchangeWebServices.DefaultShapeNamesType.IdOnly
Dim hasAttachPath As New ExchangeWebServices.PathToUnindexedFieldType
hasAttachPath.FieldURI = ExchangeWebServices.UnindexedFieldURIType.itemHasAttachments
Dim attachmentsPath As New ExchangeWebServices.PathToUnindexedFieldType
attachmentsPath.FieldURI = ExchangeWebServices.UnindexedFieldURIType.itemAttachments
' Add these to the list of properties to fetch....
getItemRequest.ItemShape.AdditionalProperties = New ExchangeWebServices.BasePathToElementType() { _
hasAttachPath, attachmentsPath}
' Now make the call.
Dim getItemResponse As ExchangeWebServices.GetItemResponseType = binding.GetItem(getItemRequest)
' getItem returns ItemInfoResponseMessages. Since we only requested one item, we should only
' get back one response message.
Dim getItemResponseMessage As ExchangeWebServices.ItemInfoResponseMessageType = TryCast( _
getItemResponse.ResponseMessages.Items(0), ExchangeWebServices.ItemInfoResponseMessageType)
' Like all good, happy and compliant developers [sic], we should check our response code....
If getItemResponseMessage.ResponseCode = ExchangeWebServices.ResponseCodeType.NoError Then
' STEP 2: Grab the Attachment IDs from our item
Dim item As ExchangeWebServices.ItemType = getItemResponseMessage.Items.Items(0)
If item.HasAttachments AndAlso item.Attachments IsNot Nothing AndAlso item.Attachments.Length > 0 Then
Dim attachmentIds As New List(Of ExchangeWebServices.RequestAttachmentIdType)
For attachmentIndex As Integer = 0 To item.Attachments.Length - 1
' For now, let's only consider file attachments instead of item attachments.
Dim almostAnAttachment As ExchangeWebServices.FileAttachmentType = TryCast( _
item.Attachments(attachmentIndex), ExchangeWebServices.FileAttachmentType)
If almostAnAttachment IsNot Nothing Then
' VERY IMPORTANT! The attachment collection returned by GetItem only has meta data
' about the attachments, but DOES NOT INCLUDE THE ACTUAL CONTENT. We must use
' GetAttachment to get the actual attachment.
Dim requestId As New ExchangeWebServices.RequestAttachmentIdType
requestId.Id = almostAnAttachment.AttachmentId.Id
attachmentIds.Add(requestId)
End If
Next
' Now that we have all of the attachment IDs, let's make a single GetAttachment call to
' get them all in one shot.
Dim getAttachmentRequest As New ExchangeWebServices.GetAttachmentType
' Oddly enough, just create an EMPTY (non-null) attachment response shape.
getAttachmentRequest.AttachmentShape = New ExchangeWebServices.AttachmentResponseShapeType
getAttachmentRequest.AttachmentIds = attachmentIds.ToArray()
Dim getAttachmentResponse As ExchangeWebServices.GetAttachmentResponseType = _
binding.GetAttachment(getAttachmentRequest)
' Now, here we asked for multiple items. As such, we will get back multiple response
' messages.
For Each attachmentResponseMessage As ExchangeWebServices.AttachmentInfoResponseMessageType _
In getAttachmentResponse.ResponseMessages.Items
If attachmentResponseMessage.ResponseCode = ExchangeWebServices.ResponseCodeType.NoError Then
' We only asked for file attachments above, so we should only get FileAttachments.
' If you are really paranoid, you can check for null after this again.
Dim fileAttachment As ExchangeWebServices.FileAttachmentType = TryCast( _
attachmentResponseMessage.Attachments(0), ExchangeWebServices.FileAttachmentType)
' Now, just save out the file contents.
Using file As System.IO.FileStream = System.IO.File.Create(System.IO.Path.Combine(destinationPath, fileAttachment.Name))
file.Write(fileAttachment.Content, 0, fileAttachment.Content.Length)
file.Flush()
file.Close()
End Using
End If
Next
End If
End If
End Sub
End Module
End Namespace
One final note: You will use the same .asmx link both to create the web reference to EWS and to connect to the server to make the actual calls. This had me stumped for a bit.
Good luck!
Related
I am trying to figure out how to set Users to an array of groups with Data I pulled from another user. I am in the process of creating a User Creation GUI and I am stuck because I am not sure if the data I have is an acceptable to pass through?
Currently I have the getGroups class which grabs the groups from a user that already exsists in AD. Which is represented in the code below:
Public Function getUserGroups(ByVal Username) As Array
Dim root As DirectoryEntry = New DirectoryEntry("L....")
Dim _objDirSearcher As DirectorySearcher = New DirectorySearcher(root)
_objDirSearcher.Filter = "(&(objectCategory=user)(name=" + Username.ToString() + "))"
_objDirSearcher.PropertiesToLoad.Add("memberOf")
Dim arr As Object = Nothing
Dim arrcol As Object() = Nothing
Try
'get all the user objects matching with the search pattern given
Dim _objResults As SearchResultCollection = _objDirSearcher.FindAll()
'loop with in each object
Dim _objResult As SearchResult
For Each _objResult In _objResults
'Check for properties available
If (Not _objResult Is Nothing) And _objResult.GetDirectoryEntry().Properties.Count > 0 Then
'verify for the mobile property not null
If Not _objResult.GetDirectoryEntry().Properties("memberOf").Value Is Nothing Then
If TypeOf _objResult.GetDirectoryEntry().Properties("memberOf").Value Is Object() Then
arr = CType(_objResult.GetDirectoryEntry().Properties("memberOf").Value, Object())
ElseIf TypeOf _objResult.GetDirectoryEntry().Properties("memberOf").Value Is Object Then
arr = CType(_objResult.GetDirectoryEntry().Properties("memberOf").Value, Object)
End If
Exit For
End If
End If
Next
Catch e As Exception
Return Nothing
End Try
Return arr
End Function
Then I have some code below to add ad user to group this is the part I am unclear if I did right. The Username variable will hold the newly created username and then pass the array of groups from the other user that is currently in format like "CN=group name, ou="test",DC=""...."
Private Sub adUserToGroup(ByVal user As String, ByVal listGroup As Array)
' sDomainName represents the location of your LDAP server
Dim sDomainName As String = "LDAP://ads.yourdomain.edu"
Dim adUserFolder As DirectoryEntry = New DirectoryEntry("LDAP://ads.yourdommain.edu/DC=ads,DC=yourdomain,DC=edu")
' This user is an active directory user and it will need access to write to the group you're trying to add to
adUserFolder.Username = "<insert user to authenticate as>"
adUserFolder.Password = "<insert password>"
Dim adSearch As New System.DirectoryServices.DirectorySearcher(adUserFolder)
For i = 0 To UBound(listGroup)
' bpell being the name of the user that you want to add.
listGroup(i).Properties("member").Add("CN=" + user + ",OU=Accounts,DC=ads,DC=mydomain,DC=edu")
listGroup(i).CommitChanges()
Next
End Sub
Does the code above look correct for what I need it to do. Should I revise it?
I figured it out, I had to break it apart and add the "Children" class to be able to find and access the group. I also made a for loop that strips the "DC" attributes from every string in the array because DC is already established in the LDAP path.
This is the final product. However I may initilize currentgroup out side the for loop as I feel like opening multiple sessions to add value to a group may cause issues.
Private Sub adUserToGroup(ByVal user As String, ByVal listGroup As Array)
Dim de As DirectoryEntry = New DirectoryEntry()
de.Path = "LDAP://domain.com/DC=Test,DC=COM"
de.AuthenticationType = AuthenticationTypes.Secure
de.Username = AuthUser
de.Password = AuthPass
Dim root As DirectoryEntries = de.Children
'1. Create user account
For i = 0 To UBound(listGroup)
Dim currentGroup As DirectoryEntry = de.Children.Find(listGroup(i), "group")
'Dim currentGroup As DirectoryEntry = de.find(listGroup(i))
currentGroup.Properties("member").Add("CN=" + user + ",OU=Employees,OU=Users,DC=test,DC=com")
currentGroup.CommitChanges()
Next
de.Close()
End Sub
I'm basically writing a custom Error Logging Form for one of my applications because users cannot be trusted to report the errors to me.
I am obtaining the Form Name using the 'MethodBase' Object and then getting the DeclaringType Name.
Dim st As StackTrace = New StackTrace()
Dim sf As StackFrame = st.GetFrame(1)
Dim mb As MethodBase = sf.GetMethod()
Dim dt As String = mb.DeclaringType.Name
How can I then use this to obtain the Form Object so I can pass this to my 'screenshot method' that screenshots the particular form referenced.
Public Sub SaveAsImage(frm As Form)
'Dim fileName As String = "sth.png"
'define fileName
Dim format As ImageFormat = ImageFormat.Png
Dim image = New Bitmap(frm.Width, frm.Height)
Using g As Graphics = Graphics.FromImage(image)
g.CopyFromScreen(frm.Location, New Point(0, 0), frm.Size)
End Using
image.Save(_LogPath & Date.Now.ToString("ddMMyyyy") & ".png", format)
End Sub
I posted the same solution to a similar question. Try this:
Dim frm = Application.OpenForms.Item(dt)
I have an Access Database linked with a VB project through a data source. In the database on one of the tables, I have an OLE Object field. I have saved pictures in .BMP format and .JPG format in this field. The problem I am encountering is loading this image into my application. This is what I would like to be able to do:
ButtonMeal1.BackgroundImage = IPOSDBDataSet.Meals.Rows(0).Item(5)
Where Item(5) is the column of the row where the image is stored.
Is there another way of doing this. Do I have to load the picture into the program by storing it as a variable, and then using that to change the background image of the button. There are no clear answers on the internet regarding my issue. Please help!
EDIT 1:
After doing some more research, I found some code and adjusted it to try fix my problem.
Dim ImageByteArray As Byte() = CType(IPOSDBDataSet.Meals.Rows(0).Item(5), Byte())
Dim ImageMemoryStream As MemoryStream = New IO.MemoryStream(ImageByteArray)
Dim MyImage As Image = Drawing.Image.FromStream(ImageMemoryStream)
PictureBox1.Image = MyImage
However, I receive the error "Parameter is Not Valid" with the 3rd line of the code. Would anyone be able to tell me how I could adjust my code to fix this issue, or tell me if I am doing something completely wrong?
EDIT 2:
I keep on changing the code around, but the error is always "Parameter is not valid.". What parameter is not valid?
EDIT 3:
No matter what I change it to, the error still persists. What is this parameter that is causing all my issues?
Dim ImageByteArray As Byte() = CType(IPOSDBDataSet.Meals.Rows(0).Item(5), Byte())
Dim ImageMemoryStream As MemoryStream = New IO.MemoryStream(ImageByteArray)
Dim ImageStream As Stream = ImageMemoryStream
Dim MyImage As Image = Drawing.Image.FromStream(ImageStream)
PictureBox1.Image = MyImage
EDIT 4:
Can anyone please help? I really need to be able to implement this into my program. Is there any other possible way of storing images in an access database, and importing them into my vb.net program?
Credit goes to TnTinMan from CodeProject for the answer. Hopefully this helps someone else:
Dim ImageByteArray As Byte() = CType(DataSet.Table.Rows(RowNo).Item(ItemNo), Byte())
Dim ImageMemoryStream As MemoryStream = New IO.MemoryStream(GetImageBytesFromOLEField(ImageByteArray))
Dim MyImage As Image = Drawing.Image.FromStream(ImageMemoryStream)
Friend Shared Function GetImageBytesFromOLEField(ByVal oleFieldBytes() As Byte) As Byte()
Dim BITMAP_ID_BLOCK As String = "BM"
Dim JPG_ID_BLOCK As String = ChrW(&HFF).ToString() & ChrW(&HD8).ToString() & ChrW(&HFF).ToString()
Dim PNG_ID_BLOCK As String = ChrW(&H89).ToString() & "PNG" & vbCrLf & ChrW(&H1A).ToString() & vbLf
Dim GIF_ID_BLOCK As String = "GIF8"
Dim TIFF_ID_BLOCK As String = "II*" & ChrW(&H0).ToString()
Dim imageBytes() As Byte
' Get a UTF7 Encoded string version
Dim u7 As System.Text.Encoding = System.Text.Encoding.UTF7
Dim strTemp As String = u7.GetString(oleFieldBytes)
Dim st2 As String = System.Text.Encoding.UTF8.GetString(oleFieldBytes)
' Get the first 300 characters from the string
Dim strVTemp As String = strTemp.Substring(0, 300)
' Search for the block
Dim iPos As Integer = -1
If strVTemp.IndexOf(BITMAP_ID_BLOCK) <> -1 Then
iPos = strVTemp.IndexOf(BITMAP_ID_BLOCK)
ElseIf strVTemp.IndexOf(JPG_ID_BLOCK) <> -1 Then
iPos = strVTemp.IndexOf(JPG_ID_BLOCK)
ElseIf strVTemp.IndexOf(PNG_ID_BLOCK) <> -1 Then
iPos = strVTemp.IndexOf(PNG_ID_BLOCK)
ElseIf strVTemp.IndexOf(GIF_ID_BLOCK) <> -1 Then
iPos = strVTemp.IndexOf(GIF_ID_BLOCK)
ElseIf strVTemp.IndexOf(TIFF_ID_BLOCK) <> -1 Then
iPos = strVTemp.IndexOf(TIFF_ID_BLOCK)
Else
Throw New Exception("Unable to determine header size for the OLE Object")
End If
' From the position above get the new image
If iPos = -1 Then
Throw New Exception("Unable to determine header size for the OLE Object")
End If
imageBytes = New Byte(CInt(oleFieldBytes.LongLength - iPos - 1)) {}
Array.ConstrainedCopy(oleFieldBytes, iPos, imageBytes, 0, oleFieldBytes.Length - iPos)
Return imageBytes
End Function
There isn't really such a thing as an 'image' stored in an Access table, only a binary stream. Therefore, the left hand side of your expression doesn't know that the right hand side is providing an image. You would have to stream the binary stream into a stream in VB.NET, then use System.Graphics methods to make it into a BMP or PNG or whatever. You could assign that object to the button.
still show error: index and length must refer to a location within the string.Parameter name: len
How can my VB6 form POST 2 vars, pull the results from a URL and then assign a VB6 var to the results?
I need someone to show me VERY basic VB6 sample code or point me in the right direction. This is the simplest form - in the final product, the PHP vars will write to MySQL, but that's not what i need help with.
I have a simple PHP page that accepts 2 parameters:
test.php?var1=secret&var2=pass
Here's my really simple PHP code
<?php
$var1 = $_GET['var1'];
$var2 = $_GET['var2'];
$varAcc = "ACCEPTED";
$varDen = "DENIED";
if ($var1 === "secret" && $var2 === "pass")
{
echo $varAcc;
}
else
{
echo $varDen;
}
?>
The logic behind this is gonna be VB6 login with "userName", "passWord" and "hardWareID", and send a hash. The hash will be checked against MySQL to see whether it exists, and returns YES or NO for access, how many days left on their account, and some other details, like FULL NAME, ACCOUNT INFO, etc.
( NO.. I do not want to use XML, just thought i would put that out there.. Just POST & Receive to vars)
Thank You...
VB forms don't have any built-in mechanism for sending HTTP requests. Some may suggest you use the Internet Transfer Control. However, the VB UserControl has a mechanism for HTTP that you can use without the need for third party controls, assuming you use the GET method, and use the query string to pass your parameters. If you have to use POST, you must use the Internet Transfer Control.
Create a VB project with a reference to "Microsoft Scripting Runtime" (see the menu Project=>References). Add a UserControl. Call it "HttpService". Set InvisibleAtRuntime=True. Add the following code to the UserControl:
Option Explicit
Private Const m_ksProperty_Default As String = ""
Private m_sHost As String
Private m_nPort As Long
Private m_sPath As String
Private m_dctQueryStringParameters As Scripting.Dictionary
Private m_sOutput As String
' Ensure that all parts of the query string are deleted.
Public Sub ClearQueryString()
Set m_dctQueryStringParameters = New Scripting.Dictionary
End Sub
' Executes "GET" method for URL.
Public Function Get_() As String
' Read in data from URL. UserControl_AsyncReadComplete will fire when finished.
UserControl.AsyncRead "http://" & m_sHost & ":" & CStr(m_nPort) & "" & m_sPath & "?" & GetQueryString(), vbAsyncTypeByteArray, m_ksProperty_Default, vbAsyncReadSynchronousDownload
' Return the contents of the buffer.
Get_ = m_sOutput
' Clear down state.
m_sOutput = vbNullString
End Function
' Returns query string based on dictionary.
Private Function GetQueryString() As String
Dim vName As Variant
Dim sQueryString As String
For Each vName In m_dctQueryStringParameters
sQueryString = sQueryString & CStr(vName) & "=" & m_dctQueryStringParameters.Item(vName) & "&"
Next vName
GetQueryString = Left$(sQueryString, Len(sQueryString) - 1)
End Function
' Sets the remote host.
Public Property Let Host(ByVal the_sValue As String)
m_sHost = the_sValue
End Property
' Sets the directory and filename part of the URL.
Public Property Let Path(ByVal the_sValue As String)
m_sPath = the_sValue
End Property
' Sets the port number for this request.
Public Property Let Port(ByVal the_nValue As Long)
m_nPort = the_nValue
End Property
' Sets a name/value pair in the query string. Supports duplicate names.
Public Property Let QueryStringParameter(ByVal the_sName As String, ByVal the_sValue As String)
m_dctQueryStringParameters.Item(the_sName) = the_sValue
End Property
' Fired when the download is complete.
Private Sub UserControl_AsyncReadComplete(AsyncProp As AsyncProperty)
' Gets the data from the internet transfer.
m_sOutput = StrConv(AsyncProp.Value, vbUnicode)
End Sub
Private Sub UserControl_Initialize()
' Initialises the scripting dictionary.
Set m_dctQueryStringParameters = New Scripting.Dictionary
End Sub
To use this UserControl, add it to your form. Call it "HttpService". Add a TextBox called "txtOutput" to test the following code on the form:
HttpService.Host = "localhost"
HttpService.Port = 80
HttpService.Path = "/test.php"
HttpService.QueryStringParameter("var1") = "secret"
HttpService.QueryStringParameter("var2") = "pass"
txtOutput.Text = HttpService.Get_
If you must use POST, then you will have to use the Internet Transfer Control. In the VB6 IDE, press CTL-T, and select "Microsoft Internet Transfer Control 6.0". Press Ok.
Add an instance of the control to the form. Call it "Inet". Add a CommandButton called "cmdPost" to the form. Add a reference to "Microsoft Scripting Runtime" (see the menu Project=>References).
Add the following code to your form:
Option Explicit
Private Declare Function InternetCanonicalizeUrl Lib "Wininet.dll" Alias "InternetCanonicalizeUrlW" ( _
ByVal lpszUrl As Long, _
ByVal lpszBuffer As Long, _
ByRef lpdwBufferLength As Long, _
ByVal dwFlags As Long _
) As Long
Private m_sData As String
Private m_nDataReceived As Long
Private m_bPostActive As Boolean
Private m_bDataReceived As Boolean
Private m_bError As Boolean ' For error handling.
Private m_bDisconnected As Boolean
Private Sub cmdPost_Click()
Dim dctParameters As Scripting.Dictionary
txtOutput.Text = vbNullString
m_sData = vbNullString
Set dctParameters = New Scripting.Dictionary
dctParameters.Add "var1", "secret"
dctParameters.Add "var2", "pass"
txtOutput.Text = Post("http://localhost:80/test.php", dctParameters)
End Sub
' Returns post data string based on dictionary.
Private Function GetPostDataString(ByRef the_dctParameters As Scripting.Dictionary) As String
Dim vName As Variant
Dim sPostDataString As String
For Each vName In the_dctParameters
sPostDataString = sPostDataString & UrlEncode(CStr(vName)) & "=" & UrlEncode(CStr(the_dctParameters.Item(vName))) & "&"
Next vName
GetPostDataString = Left$(sPostDataString, Len(sPostDataString) - 1)
End Function
Private Sub Inet_StateChanged(ByVal State As Integer)
' Ignore state change if we are outside the Post function.
If m_bPostActive Then
Select Case State
Case StateConstants.icResponseReceived
ReceiveData False
Case StateConstants.icResponseCompleted
ReceiveData True
Case StateConstants.icDisconnected
m_bDisconnected = True
Case StateConstants.icError
m_bError = True
End Select
End If
End Sub
' Synchronous Post function.
Private Function Post(ByRef the_sURL As String, ByRef the_dctParameters As Scripting.Dictionary)
Dim sPostData As String
Dim sHeaders As String
' Flag that we are in the middle of this function.
m_bPostActive = True
' Create a string containing the POST parameters.
sPostData = GetPostDataString(the_dctParameters)
' Create a headers string to allow POST.
sHeaders = _
"Content-Type: application/x-www-form-urlencoded" & vbNewLine & _
"Content-Length: " & CStr(Len(sPostData)) & vbNewLine & _
"Connection: Keep-Alive" & vbNewLine & _
"Cache-Control: no-cache" & vbNewLine
Inet.Execute the_sURL, "POST", GetPostDataString(the_dctParameters), sHeaders
' Allow Inet events to fire.
Do
DoEvents
Loop Until m_bDataReceived Or m_bDisconnected
If m_bDataReceived Then
Post = m_sData
End If
' Clear all state flags to defaults.
m_bDataReceived = False
m_bDisconnected = False
m_bError = False
m_sData = vbNullString
m_nDataReceived = 0
' Flag that we have exited this function.
m_bPostActive = False
End Function
' Receive as much data as we can.
' <the_bCompleted> should be True if the response is completed i.e. all data is available.
Private Sub ReceiveData(ByVal the_bCompleted As Boolean)
Const knBufferSize As Long = 1024
Dim nContentLength As Long
Dim sContentType As String
Dim sChunk As String
Dim nChunkSize As Long
' If we haven't yet created our buffer, do so now, based on the size of the incoming data.
If m_nDataReceived = 0 Then
nContentLength = CLng(Inet.GetHeader("Content-length"))
m_sData = Space$(nContentLength)
' You might want to do a check on the content type here, and if it is wrong, cancel the request with Inet.Cancel .
sContentType = Inet.GetHeader("Content-type")
End If
' Retrieve data until we have all the data.
Do Until m_nDataReceived = Len(m_sData)
' If called when not all data has been received, then exit function if it is currently executing.
If Not the_bCompleted Then
If Inet.StillExecuting Then
Debug.Print "Exiting"
Exit Sub
End If
End If
' Get a chunk, copy it into the output buffer, and increment the amount of data received.
sChunk = Inet.GetChunk(knBufferSize, DataTypeConstants.icString)
nChunkSize = Len(sChunk)
Mid$(m_sData, m_nDataReceived + 1, nChunkSize) = sChunk
m_nDataReceived = m_nDataReceived + nChunkSize
Loop
' Flag that all data has been retrieved.
m_bDataReceived = True
End Sub
' Encode the URL data.
Private Function UrlEncode(ByVal the_sURLData As String) As String
Dim nBufferLen As Long
Dim sBuffer As String
' Only exception - encode spaces as "+".
the_sURLData = Replace$(the_sURLData, " ", "+")
' Try to #-encode the string.
' Reserve a buffer. Maximum size is 3 chars for every 1 char in the input string.
nBufferLen = Len(the_sURLData) * 3
sBuffer = Space$(nBufferLen)
If InternetCanonicalizeUrl(StrPtr(the_sURLData), StrPtr(sBuffer), nBufferLen, 0&) Then
UrlEncode = Left$(sBuffer, nBufferLen)
Else
UrlEncode = the_sURLData
End If
End Function
I have a bot that is scanning my inbox periodically for specific emails. Whenever the code below is firing the cursor blinks and flashes when the cursor is over the Lotus Notes UI. Google returned about 5 results for my search and none of them seemed to address this issue. It's not preventing my program from working but it does look pretty bad aesthetically. Anyone out there have any ideas? Thanks!
*I also tagged this as C# to get more eyes looking at it. I'd prefer a vb.net solution but C# is welcome and appreciated as well.
Dim NS As Object = CreateObject("Notes.NotesSession")
Dim NDB As Object = NS.GetDatabase("", "")
If NDB.IsOpen = False Then NDB.Openmail()
Dim NV As Object = NDB.GetView("($Inbox)")
NV.refresh()
Dim ND As Object = NV.GetFirstDocument
Dim aItems As Array
Dim dInfo As Dictionary(Of String, String)
Dim EmailCount As Integer = NV.entrycount
Dim iCurrent As Integer = 0
Dim EmailDate As DateTime
Dim Subject As String, Body As String, sFrom As String
Do
iCurrent += 1
aItems = ND.Items
dInfo = New Dictionary(Of String, String)
For i As Integer = 0 To aItems.Length - 1
If Not dInfo.ContainsKey(aItems(i).name) Then
dInfo.Add(aItems(i).name, aItems(i).text)
End If
Next
EmailDate = CDate(dInfo("DeliveredDate"))
Subject = dInfo("Subject")
Body = dInfo("Body")
sFrom = dInfo("From")
If NV.GetNextDocument(ND) Is Nothing Then Exit Do
ND = NV.GetNextDocument(ND)
Loop
The Notes.NotesSession class is an OLE class, which means that it interacts with the Notes UI.
You should be using the COM version of the class instead, which is Lotus.NotesSession