I have the following code:
Option Explicit
Dim WithEvents TargetFolderItems As Items
'set the string constant for the path to save attachments
Const FILE_PATH As String = "H:\Attachment"
Private Sub Application_Startup()
Dim ns As Outlook.NameSpace
Set ns = Application.GetNamespace("MAPI")
Set TargetFolderItems = ns.Folders.Item( _
"Inbox").Folders.Item("BS CDGL").Items
End Sub
Sub TargetFolderItems_ItemAdd(ByVal Item As Object)
Dim olAtt As Attachment
Dim i As Integer
If Item.Attachments.Count > 0 Then
For i = 1 To Item.Attachments.Count
Set olAtt = Item.Attachments(i)
'save the attachment
olAtt.SaveAsFile FILE_PATH & olAtt.FileName
Next
End If
Set olAtt = Nothing
End Sub
Private Sub Application_Quit()
Dim ns As Outlook.NameSpace
Set TargetFolderItems = Nothing
Set ns = Nothing
End Sub
It throws an error at line 2 character 16, the "TargetFolderItems" part, the code is to automatically save attachments from emails in the inbox in Outlook, any help on getting this working would be much appreciated :)
Thanks
Related
I am really new to VBA, was trying to play around with really basic things, userform and vlookup. Couldn't figure out vlookup error after many hours. Appreciate any input!
Private Sub cmdClose_Click()
Unload Me
End Sub
Private Sub cmdSend_Click()
' emailcommand Macro
'
Dim oApp As Outlook.Application
Dim oMail As MailItem
Set oApp = New Outlook.Application
Set oMail = oApp.CreateItem(olMailItem)
With oMail
.To = emailaddress.Value
.Subject = Subjectbox.Value
.Body = "Hi, " & Fundname.Value & " is ready"
.Display
Application.SendKeys "%s"
End With
End Sub
Private Sub Fundnumber_Change()
Dim ws As Worksheet
Set ws = Sheets("Matrix")
With Me
.Fundname.Text = Application.VLookup(.Fundnumber.Text, ws.Range("A2:D141"), 4, False)
End With
End Sub
Excel File Link
This is a code from an you-tube video. The below code is giving an Compiler error : Userdefined Type not defined.
Sub SendEmail(what_address As String, Subject_line As String, mail_body As String)
'Dim olApp As Outlook.Application
Set olApp = CreateObject("outlook.Application")
'Dim olMail As Outlook.MailItem
Set olMail = olApp.CreateItem(olMailItem)
olMail.To = what_address
olMail.Subject = Subject_line
olMail.body = mial_body
olMail.send
End Sub
Sub SendMassEmail()
row_number = 1
Do
DoEvents
row_number = row_number + 1
Dim mail_body_message As String
Dim full_name As String
Dim Promoscode As String
mail_body_message = Sheet1.Range("J2")
full_name = Sheet1.Range("B" & row_number) & " " & Sheet1.Range("C" & row_number)
promo_code = Sheet1.Range("D" & row_number)
mial_body_message = Replace(mail_body_message, "replace_name_here", full_name)
Call SendEmail(Sheet1.Range("A1" & row_number), "This is a test e-mail", mail_body_message)
Loop Until row_number = 6
End Sub
I am having an compiler error, I have checked everything but...not sure what is cousing this issue.
Use the Recipients property of the MailItem class to specify the recipients instead of the To property.
The Recipients class provides the Add method which allows to create and add a new recipient to the collection. Then use the Resolve method to attempt to resolve a Recipient object against the Address Book.
Sub AssignTask()
Dim myItem As Outlook.TaskItem
Dim myDelegate As Outlook.Recipient
Set MyItem = Application.CreateItem(olTaskItem)
MyItem.Assign
Set myDelegate = MyItem.Recipients.Add("DL name")
myDelegate.Resolve
If myDelegate.Resolved Then
myItem.Subject = "Prepare Agenda For Meeting"
myItem.DueDate = Now + 30
myItem.Display
myItem.Send
End If
End Sub
In Visual studio 2010>New Project>Visual Basic>Windows>Windows forms Application, i have made a form (form1.vb) and a database (Local Database>"Database1.sdf") and a Table with 3 Columns ("Name","City","Age").
I like to copy this 3 fields and paste to document "test1.doc" (open this with Ms Office or Open Office Writer). I have bookmarks ("PasteName", PasteCity", "PasteAge") in specified places in test1.doc .
How to make a button to open the document "test1.doc" and copy - paste this 3 items from table to doc and preview before print it? (not for save - only print preview and close without save after printing)
I have find this code for MS Office but didn't work in Visual Studio. I like something similar. (this code is for a doc Form Fields - I have Bookmarks in my doc).
Private Sub cmdPrint_Click()
Dim appWord As Word.Application
Dim doc As Word.Document
Set appWord = GetObject(, "Word.Application")
Set appWord = New Word.Application
Set doc = appWord.Documents.Open("C:\WordForms\CustomerSlip.doc", , True)
With doc
.FormFields("fldCustomerID").Result = Me!CustomerID
.FormFields("fldCompanyName").Result = Me!CompanyName
.FormFields("fldContactName").Result = Me!ContactName
.Visible = True
.Activate
End With
Set doc = Nothing
Set appWord = Nothing
End Sub
Thanks programers people
This works for me. (button action)
Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
'Print customer slip for current customer.
Dim appWord As Word.Application
Dim doc As Word.Document
'Avoid error 429, when Word isn't open.
On Error Resume Next
Err.Clear()
'Set appWord object variable to running instance of Word.
appWord = GetObject(, "Word.Application")
If Err.Number <> 0 Then
'If Word isn't open, create a new instance of Word.
appWord = New Word.Application
End If
doc = appWord.Documents.Open("D:\Test.docx", , True)
doc.Visible()
doc.Activate()
With doc.Bookmarks
.Item("Name").Range.Text = Me.NameID.Text
.Item("City").Range.Text = Me.CityID.Text
End With
Dim dlg As Word.Dialog
dlg = appWord.Dialogs.Item(Word.WdWordDialog.wdDialogFilePrint)
dlg.Display()
'doc.Printout
doc = Nothing
appWord = Nothing
Exit Sub
errHandler:
MsgBox(Err.Number & ": " & Err.Description)
End Sub
I would like to add a Control and an associated event at runtime in Excel using VBA but I don't know how to add the events.
I tried the code below and the Button is correctly created in my userform but the associated click event that should display the hello message is not working.
Any advice/correction would be welcome.
Dim Butn As CommandButton
Set Butn = UserForm1.Controls.Add("Forms.CommandButton.1")
With Butn
.Name = "CommandButton1"
.Caption = "Click me to get the Hello Message"
.Width = 100
.Top = 10
End With
With ThisWorkbook.VBProject.VBComponents("UserForm1.CommandButton1").CodeModule
Line = .CountOfLines
.InsertLines Line + 1, "Sub CommandButton1_Click()"
.InsertLines Line + 2, "MsgBox ""Hello!"""
.InsertLines Line + 3, "End Sub"
End With
UserForm1.Show
The code for adding a button at runtime and then to add events is truly as simple as it is difficult to find out. I can say that because I have spent more time on this perplexity and got irritated more than in anything else I ever programmed.
Create a Userform and put in the following code:
Option Explicit
Dim ButArray() As New Class2
Private Sub UserForm_Initialize()
Dim ctlbut As MSForms.CommandButton
Dim butTop As Long, i As Long
'~~> Decide on the .Top for the 1st TextBox
butTop = 30
For i = 1 To 10
Set ctlbut = Me.Controls.Add("Forms.CommandButton.1", "butTest" & i)
'~~> Define the TextBox .Top and the .Left property here
ctlbut.Top = butTop: ctlbut.Left = 50
ctlbut.Caption = Cells(i, 7).Value
'~~> Increment the .Top for the next TextBox
butTop = butTop + 20
ReDim Preserve ButArray(1 To i)
Set ButArray(i).butEvents = ctlbut
Next
End Sub
Now you need to add a Class Module to your code for the project. Please remember it's class module, not Standard Module.
The Object butEvents is the button that was clicked.
Put in the following simple code (in my case the class name is Class2).
Public WithEvents butEvents As MSForms.CommandButton
Private Sub butEvents_click()
MsgBox "Hi Shrey from " & butEvents.Caption
End Sub
That's it. Now run it!
Try this:
Sub AddButtonAndShow()
Dim Butn As CommandButton
Dim Line As Long
Dim objForm As Object
Set objForm = ThisWorkbook.VBProject.VBComponents("UserForm1")
Set Butn = objForm.Designer.Controls.Add("Forms.CommandButton.1")
With Butn
.Name = "CommandButton1"
.Caption = "Click me to get the Hello Message"
.Width = 100
.Top = 10
End With
With objForm.CodeModule
Line = .CountOfLines
.InsertLines Line + 1, "Sub CommandButton1_Click()"
.InsertLines Line + 2, "MsgBox ""Hello!"""
.InsertLines Line + 3, "End Sub"
End With
VBA.UserForms.Add(objForm.Name).Show
End Sub
This permanently modifies UserForm1 (assuming you save your workbook). If you wanted a temporary userform, then add a new userform instead of setting it to UserForm1. You can then delete the form once you're done with it.
Chip Pearson has some great info about coding the VBE.
DaveShaw, thx for this code man!
I have used it for a togglebutton array (put a 'thumbnail-size' picture called trainer.jpg in the same folder as the excel file for a togglebutton with a picture in it). In the 'click' event the invoker is also available (by the object name as a string)
In the form:
Dim CreateTrainerToggleButtonArray() As New ToggleButtonClass
Private Sub CreateTrainerToggleButton(top As Integer, id As Integer)
Dim pathToPicture As String
pathToPicture = ThisWorkbook.Path & "\trainer.jpg"
Dim idString As String
idString = "TrainerToggleButton" & id
Dim cCont As MSForms.ToggleButton
Set cCont = Me.Controls.Add _
("Forms.ToggleButton.1")
With cCont
.Name = idString
.Width = 20
.Height = 20
.Left = 6
.top = top
.picture = LoadPicture(pathToPicture)
End With
ReDim Preserve CreateTrainerToggleButtonArray(1 To id)
Set CreateTrainerToggleButtonArray(id).ToggleButtonEvents = cCont
CreateTrainerToggleButtonArray(id).ObjectName = idString
End Sub
and a class "ToggleButtonClass"
Public WithEvents ToggleButtonEvents As MSForms.ToggleButton
Public ObjectName As String
Private Sub ToggleButtonEvents_click()
MsgBox "DaveShaw is the man... <3 from your friend: " & ObjectName
End Sub
Now just simple call from UserForm_Initialize
Private Sub UserForm_Initialize()
Dim index As Integer
For index = 1 To 10
Call CreateTrainerToggleButton(100 + (25 * index), index)
Next index
End Sub
This was my solution to add a commandbutton and code without using classes
It adds a reference to allow access to vbide
Adds the button
Then writes a function to handle the click event in the worksheet
Sub AddButton()
Call addref
Set rng = DestSh.Range("B" & x + 3)
'Set btn = DestSh.Buttons.Add(rng.Left, rng.Top, rng.Width, rng.Height)
Set myButton = ActiveSheet.OLEObjects.Add(ClassType:="Forms.CommandButton.1", Left:=rng.Left, Top:=rng.Top, Height:=rng.Height * 3, Width:=rng.Width * 3)
DoEvents
With myButton
'.Placement = XlPlacement.xlFreeFloating
.Object.Caption = "Export"
.Name = "BtnExport"
.Object.PicturePosition = 1
.Object.Font.Size = 14
End With
Stop
myButton.Object.Picture = LoadPicture("F:\Finalised reports\Templates\Macros\evolution48.bmp")
Call CreateButtonEvent
End Sub
Sub addref()
On Error Resume Next
Application.VBE.ActiveVBProject.References.AddFromFile "C:\Program Files (x86)\Common Files\Microsoft Shared\VBA\VBA6\VBE6EXT.OLB"
Application.VBE.ActiveVBProject.References.AddFromFile "C:\Program Files\Common Files\Microsoft Shared\VBA\VBA6\VBE6EXT.OLB"
End Sub
Private Sub CreateButtonEvent()
On Error GoTo errtrap
Dim oXl As Application: Set oXl = Application
oXl.EnableEvents = False
oXl.DisplayAlerts = False
oXl.ScreenUpdating = False
oXl.VBE.MainWindow.Visible = False
Dim oWs As Worksheet
Dim oVBproj As VBIDE.VBProject
Dim oVBcomp As VBIDE.VBComponent
Dim oVBmod As VBIDE.CodeModule '
Dim lLine As Single
Const QUOTE As String = """"
Set oWs = Sheets("Contingency")
Set oVBproj = ThisWorkbook.VBProject
Set oVBcomp = oVBproj.VBComponents(oWs.CodeName)
Set oVBmod = oVBcomp.CodeModule
With oVBmod
lLine = .CreateEventProc("Click", "BtnExport") + 1
.InsertLines lLine, "Call CSVFile"
End With
oXl.EnableEvents = True
oXl.DisplayAlerts = True
Exit Sub
errtrap:
End Sub
An easy way to do it:
1 - Insert a class module and write this code:
Public WithEvents ChkEvents As MSForms.CommandButton
Private Sub ChkEvents_click()
MsgBox ("Click Event")
End Sub
2 - Insert a userform and write this code:
Dim Chk As New Clase1
Private Sub UserForm_Initialize()
Dim NewCheck As MSForms.CommandButton
Set NewCheck = Me.Controls.Add("Forms.CommandButton.1")
NewCheck.Caption = "Prueba"
Set Chk.ChkEvents = NewCheck
End Sub
Now show the form and click the button
I think the code needs to be added to the Userform, not to the button itself.
So something like
With UserForm1.CodeModule
'Insert code here
End With
In place of your With ThisWorkbook
My marketing department, bless them, has decided to make a sweepstakes where people enter over a webpage. That is great but the information isn't stored to a DB of any sort but is sent to an exchange mail box as an email. Great.
My challenge is to extract the entry (and marketing info) from these emails and store them someplace more useful, say a flat file or CSV. The only saving grace is that the emails have a highly consistant format.
I am sure I could spend the time saving all the emails to files and then write an app to munge through them all but was hoping for a much more elegant solution. Can I programmatically access an exchange mailbox, read all the emails and then save that data?
Here is the code I used....
Private Sub btnGo_Click()
If ComboBox1.SelText <> "" Then
Dim objOutlook As New Outlook.Application
Dim objNameSpace As Outlook.NameSpace
Dim objInbox As MAPIFolder
Dim objMail As mailItem
//Get the MAPI reference
Set objNameSpace = objOutlook.GetNamespace("MAPI")
//Pick up the Inbox
Set objInbox = objNameSpace.GetDefaultFolder(olFolderInbox)
For Each objFolder In objInbox.Folders
If (objFolder.Name = ComboBox1.SelText) Then
Set objInbox = objFolder
End If
Next objFolder
//Loop through the items in the Inbox
Dim count As Integer
count = 1
For Each objMail In objInbox.Items
lblStatus.Caption = "Count: " + CStr(count)
If (CheckBox1.Value = False Or objMail.UnRead = True) Then
ProcessMailItem (objMail.Body)
count = count + 1
objMail.UnRead = False
End If
Next objMail
End If
End Sub
Private Sub ProcessMailItem(strBody As String)
Open "C:\file.txt" For Append As 1
Dim strTmp As String
strTmp = Replace(strBody, vbNewLine, " ")
strTmp = Replace(strTmp, vbCrLf, " ")
strTmp = Replace(strTmp, Chr(13) & Chr(10), " ")
strTmp = Replace(strTmp, ",", "_")
//Extra Processing went here (Deleted for brevity)
Print #1, strTmp
Close #1
End Sub
Private Function Strip(strStart As String, strEnd As String, strBody As String) As String
Dim iStart As Integer
Dim iEnd As Integer
iStart = InStr(strBody, strStart) + Len(strStart)
If (strEnd = "xxx") Then
iEnd = Len(strBody)
Else
iEnd = InStr(strBody, strEnd) - 1
End If
Strip = LTrim(RTrim(Mid(strBody, iStart, iEnd - iStart)))
End Function
Private Sub UserForm_Initialize()
Dim objOutlook As New Outlook.Application
Dim objNameSpace As Outlook.NameSpace
Dim objInbox As MAPIFolder
Dim objFolder As MAPIFolder
//Get the MAPI reference
Set objNameSpace = objOutlook.GetNamespace("MAPI")
//Pick up the Inbox
Set objInbox = objNameSpace.GetDefaultFolder(olFolderInbox)
//Loop through the folders under the Inbox
For Each objFolder In objInbox.Folders
ComboBox1.AddItem objFolder.Name
Next objFolder
End Sub
There's lots of different ways to get at the messages in an exchange mailbox, but since it seems this is something you're only going to want to run once to extract the data I'd suggest writing a VBA macro to run inside Outlook itself (having opened the exchange mailbox in question within Outlook). It's pretty easy to iterate through the mail items in a specific mailbox and read the body text from them. You can then write a text file with just the stuff you want.