I would like to automate my MS Outlook inbox. The idea is to move all emails (i) with a specific sender address and (ii) older than 7 days as of today into a subfolder to my inbox. Please see working example below (you may need to adjust folder names so it works on you machine).
My problem: after 88 iterations I run into a "run time error 13, type mismatch". Why does this happen after so many iterations? And, more importantly, how to fix it? Any ideas?
All default libraries are enabled on my VBE. I am using MS Office 2019.
Thank you!
'On Error Resume Next
On Error GoTo 0
'-----------------------------------------------------------------------------------------
' declare variables
'-----------------------------------------------------------------------------------------
Dim objSourceFolder As MAPIFolder
Dim objDestinationFolder As MAPIFolder
Dim objMail As MailItem ' single email
Dim objMails As Items ' all emails in source folder
Dim lngItems As Long ' number of checked emails
Dim intDays As Integer ' number of days
Dim counter As Integer ' number of moved emails
'-----------------------------------------------------------------------------------------
' email age in days
'-----------------------------------------------------------------------------------------
intDays = 7
'-----------------------------------------------------------------------------------------
' define folder (= inbox)
'-----------------------------------------------------------------------------------------
Set objSourceFolder = GetNamespace("Mapi").GetDefaultFolder(olFolderInbox)
'-----------------------------------------------------------------------------------------
' reference items in source folder
'-----------------------------------------------------------------------------------------
Set objMails = objSourceFolder.Items
'objMails.Count
'-----------------------------------------------------------------------------------------
' sort emails in source folder (oldest first)
'-----------------------------------------------------------------------------------------
objMails.Sort "ReceivedTime", False
'-----------------------------------------------------------------------------------------
' move email
'-----------------------------------------------------------------------------------------
For Each objMail In objMails
If objMail.ReceivedTime < Now - intDays Then
Select Case objMail.SenderEmailAddress
Case "mailrobot#mail.xing.com":
Set objDestinationFolder = GetNamespace("Mapi").Folders(1).Folders("Inbox").Folders("Xing")
End Select
If objDestinationFolder Is Nothing Then
Else: objMail.Move objDestinationFolder
counter = counter + 1
End If
lngItems = lngItems + 1
End If
Next
End Sub
Your code assumes that you can only have MailItem objects in the Inbox folder. You an also have ReportItem and MeetingItem objects.
Declare objMail as a generic Object and in the loop check first that the Class property is 43 (OlObjectClass.olMail)
Related
wondering if someone can help me out with the following problem.
I have staff stock areas with items regularly. As part of the stocking they are required to also charge whatever they send out. The issue is that when they charge they do the repetitive task of data entry for each item they charge out.
In my ideal setup, they can scan a barcode and the task would be completed in seconds since the barcode would contain all the data that needs to be entered.
To automate this, I was thinking of creating one barcode that can capture all the required inputs along with the tab, and enter keys they are required to input And then when the barcode is scanned from a paper print out the info would be automatically charged.
The data driving the barcode is in Excel so I'd like to create the barcode in Excel. This is where I need help, I've tried to add barcode font but it's not working and I have no experience in VBA if that is required.Any guidance would be much appreciated!
You may use barcode generation component to generate barcodes from VBA (as pictures) and insert these pictures into Excel.
Below is the sample code for ByteScout BarCode SDK (commercial component compatible with VBA) sample. Basically, if you want you may replace it with any other component that is capable of creating pictures when called from VBA.
' IMPORTANT: This demo uses VBA so if you have it disabled please temporary enable
' by going to Tools - Macro - Security.. and changing the security mode to ""Medium""
' to Ask if you want enable macro or not. Then close and reopen this Excel document
' You should have evaluation version of the ByteScout SDK installed to get it working - get it from https://bytescout.com
' If you are getting error message like
' "File or assembly named Bytescout SDK, or one of its dependencies, was not found"
' then please try the following:
'
' - Close Excel
' - (for Office 2003 only) download and install this hotfix from Microsoft:
' http://www.microsoft.com/downloads/details.aspx?FamilyId=1B0BFB35-C252-43CC-8A2A-6A64D6AC4670&displaylang=en
'
' and then try again!
'
' If you have any questions please contact us at http://bytescout.com/support/ or at support#bytescout.com
'==============================================
'References used
'=================
'Bytescout Barcode SDK
'
' IMPORTANT:
' ==============================================================
'1) Add the ActiveX reference in Tools -> References
'2) Loop through the values from the Column A for which barcode has to be generated
'3) Parse the value to Bytescout Barcode Object to generate the barcode using QR Code barcode type.
'4) Save the generated Barcode Image
'5) Insert the Barcode Image in the Column B
'6) Repeat the steps 3 to 5 till the last Value in Column A
'
'==================================================================
Option Explicit
' declare function to get temporary folder (where we could save barcode images temporary)
Declare Function GetTempPath _
Lib "kernel32" Alias "GetTempPathA" _
(ByVal nBufferLength As Long, _
ByVal lpBuffer As String) As Long
' function to return path to temporary folder
Public Function fncGetTempPath() As String
Dim PathLen As Long
Dim WinTempDir As String
Dim BufferLength As Long
BufferLength = 260
WinTempDir = Space(BufferLength)
PathLen = GetTempPath(BufferLength, WinTempDir)
If Not PathLen = 0 Then
fncGetTempPath = Left(WinTempDir, PathLen)
Else
fncGetTempPath = CurDir()
End If
End Function
Sub Barcode_Click()
'Fetch the Worksheet
Dim mySheet As Worksheet
Set mySheet = Worksheets(1) 'Barcode_Data Sheet
'temp path to save the Barcode images
Dim filePath As String
filePath = fncGetTempPath() 'Change the Path But should end with Backslash( \ )
'Prepare the Bytescout Barcode Object
'====================================
Dim myBarcode As New Bytescout_BarCode.Barcode
myBarcode.RegistrationName = "demo" 'Change the name for full version
myBarcode.RegistrationKey = "demo" 'Change the key for full version
'Barcode Settings
myBarcode.Symbology = SymbologyType_QRCode ' QR Code barcode, you may change to other barcode types like Code 39, Code 128 etc
' set barcode image quality resolution
myBarcode.ResolutionX = 300 'Resolution higher than 250 is good for printing
myBarcode.ResolutionY = 300 'Resolution higher than 250 is good for printing
myBarcode.DrawCaption = True 'Showing Barcode Captions in the Barcode Image
myBarcode.DrawCaptionFor2DBarcodes = True ' show captions for 2D barcodes like QR Code
' first clean the B column from old images (if any)
Dim Sh As Shape
With mySheet
For Each Sh In .Shapes
If Not Application.Intersect(Sh.TopLeftCell, .Range("B1:B50")) Is Nothing Then
If Sh.Type = msoPicture Then Sh.Delete
End If
Next Sh
End With
' now generate new barcodes and insert into cells in the column B
' Repeat the steps for each row from 2 to 6
Dim myVal As Integer
For myVal = 2 To 6 'change the code to all rows with values
'Parse the Value from the Column A to Bytescout Barcode Object
myBarcode.Value = mySheet.Cells(myVal, 1).Text
'Fit the barcode into 80X30 mm rectangle
myBarcode.FitInto_3 80, 30, 4 '4 refers to units of measurement as millimeter
'Save the barcode image to a file in temporary folder
myBarcode.SaveImage filePath & "myBarcode" & myVal & ".png"
'Insert the Barcode image to the Column B and resize them to fit the cell.
'==========================================================================
With mySheet.Pictures.Insert(filePath & "myBarcode" & myVal & ".png")
.ShapeRange.LockAspectRatio = True ' lock aspect ratio
.Left = mySheet.Cells(myVal, 2).Left + 1 ' set left
.Top = mySheet.Cells(myVal, 2).Top + 1 ' set right
.PrintObject = True ' allow printing this object
.Placement = xlMove ' set placement mode to move but do not resize with the cell
.ShapeRange.ScaleHeight 1, True ' set height scale to 1 (no scale)
.ShapeRange.ScaleWidth 1, True ' set width scale to 1 (no scale)
End With
Next myVal ' move to next cell in the column
' Release the Barcode Object.
Set myBarcode = Nothing
End Sub
Disclaimer: I'm relatd to ByteScout
I have developed a small VBA macro in Excel that's supposed to add the values of cells in row 15 to the values of cells in row 6 during workbook change (in my case entering a number in row 15 and pressing tab).
Initially, I developed and used it in Excel 2013, then I have switched to Mac and have since used it in Excel for Mac 2011. Now, I have installed Excel for Mac 2016 and all of a sudden, the macro doesn't work anymore.
This is the script:
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("C15:H15")) > 0 Then
Call copySub
End If
End Sub
Sub copySub()
Sheets("sheet1").Protect , UserInterFaceOnly:=True
For i = 3 To 8
Cells(6, i).Value = Cells(6, i).Value + Cells(15, i).Value
Cells(15, i).Value = 0
Next i
End Sub
When I enter a value and press tab in Excel 2016, I get the runtime error 91 "Object variable or With block variable not set". The error seems to occur in the line:
Cells(6, i).Value = Cells(6, i).Value + Cells(15, i).Value
I have also tried to store the sum in a variable before assigning it to Cells(6, i).Value, but that didn't help either.
Did Microsoft change the logic of the sheet protection, especially with the parameter UserInterFaceOnly set to true? Or what's going on here?
I hope you can help me.
Thanks,
chuky
Are you sure you've copied this code correctly? There's no way it would work in any version of Excel.
Your problems are these:
Intersect returns a Range object so your code would throw a 91 error.
There's most likely a case error in your line Sheets("sheet1").Protect ... as it's probably called "Sheet1". If so, this would throw a 91 error.
If you changed that worksheet name from "sheet1", it'd throw a 91 error.
Why are you only protecting the sheet at Worksheet_Change. This should really be done in Workbook_Open? And if you do that, how does the user change the cells without specific cells being free from protection?
It's unclear which worksheets you're referring to and where the copySub routine is held. I've updated your code as it is to remove the main errors and written in the capacity to nominate your worksheet - you'll have to adjust that as you wish. Good luck.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ws As Worksheet
Set ws = Target.Worksheet
If Not Intersect(Target, ws.Range("C15:H15")) Is Nothing Then
Call copySub(ws)
End If
End Sub
Sub copySub(ws As Worksheet)
ws.Protect , UserInterFaceOnly:=True
Application.EnableEvents = False
For i = 3 To 8
ws.Cells(6, i).Value = ws.Cells(6, i).Value + ws.Cells(15, i).Value
ws.Cells(15, i).Value = 0
Next i
Application.EnableEvents = True
End Sub
I have been toying with the below script to be able to read settings for use with my HTA (creating a game launcher).
Here is my current HTA:
http://pastebin.com/skTgqs5X
It doesn't quite work, it complains of the WScript object being required. While I understand Echo will not work like that in a HTA I am having trouble modifying the code so it will work. Even just removing all Echo references it still has an issue with objOrgIni on line 200 of the below code (with the WScript references removed):
http://pastebin.com/pGjv4Gh1
I don't even need that level of error checking as the INI will exist etc, I just need a simple way to read from and write to an INI in my scripting. Any help you guys can give me in achieving that would be great, it's a little advanced for me just yet, but I'd love an explanation as to why it fails.
There is no easy way to use INI files with VBScript. You'd have to write the functionality yourself or find some existing code that does it.
But do you really need an INI specifically or just a way to save settings? You could just keep all of your settings in a Dictionary object and serialize it as needed.
For example, here are two functions -- LoadSettings and SaveSettings -- that do just that.
Public Function LoadSettings(strFile)
Set LoadSettings = CreateObject("Scripting.Dictionary")
Dim strLine, a
With CreateObject("Scripting.FileSystemObject")
If Not .FileExists(strFile) Then Exit Function
With .OpenTextFile(strFile)
Do Until .AtEndOfStream
strLine = Trim(.ReadLine())
If InStr(strLine, "=") > 0 Then
a = Split(strLine, "=")
LoadSettings.Add a(0), a(1)
End If
Loop
End With
End With
End Function
Sub SaveSettings(d, strFile)
With CreateObject("Scripting.FileSystemObject").CreateTextFile(strFile, True)
Dim k
For Each k In d
.WriteLine k & "=" & d(k)
Next
End With
End Sub
Imagine you had the following settings file saved at c:\settings.txt:
Count=2
Name=Obama
You'd use the functions above like this:
Const SETTINGS_FILE = "c:\settings.txt"
Dim Settings
Set Settings = LoadSettings(SETTINGS_FILE)
' Show all settings...
WScript.Echo Join(Settings.Keys, ", ") ' => Count, Name
' Query a setting...
WScript.Echo Settings("Count") ' => 2
' Update a setting...
Settings("Count") = Settings("Count") + 1
' Add a setting...
Settings("New") = 1
' Save settings...
SaveSettings Settings, SETTINGS_FILE
i have a VB Script file that goes thru many files and folders within a specific directopry path, and it deletes any files thats older then 30 days
but i want to add an exception, to keep the last 14 files, so lets say if i dont have any new files yesterday, then today it will delete the file older then 14 days, and i will be left with 13 files
i want to keep the last 14 files, no matter of its age, but if there is more then 14 files, then delete the oldest
can anyone assist me where i add it in my script, and how ? here is the script im using
On Error Resume Next
Set oFileSys = WScript.CreateObject("Scripting.FileSystemObject")
sRoot = "C:\Program Files (x86)\Syslogd\Logs" 'Path root to look for files
today = Date
nMaxFileAge = 14 'Files older than this (in days) will be deleted
DeleteFiles(sRoot)
Function DeleteFiles(ByVal sFolder)
Set oFolder = oFileSys.GetFolder(sFolder)
Set aFiles = oFolder.Files
Set aSubFolders = oFolder.SubFolders
For Each file in aFiles
dFileCreated = FormatDateTime(file.DateCreated, "2")
If DateDiff("d", dFileCreated, today) > nMaxFileAge Then
file.Delete(True)
End If
Next
For Each folder in aSubFolders
DeleteFiles(folder.Path)
Next
End Function
I think you could do this a few ways. One would be to use the DIR command to sort the files and then you can just iterate that list and delete the ones starting at the 15th position. For example, this command would return just the filenames, sorted by date in descending order:
dir /o-d /a-d /b
and you could run that using Shell.Run or Shell.Exec to capture its output. The "problem" with Shell.Run is that you'd need to send the output to a file, then open the file, and read it. Not a big deal but requires file I/O. If you use Shell.Exec, you can capture the standard output directly but you have to deal with the command prompt window flashing open whenever a DIR command runs.
If you're fine with either of those "problems", then that method should work fine.
But you could do everything using the FileSystemObject. The key is to just get the date of the 14th most-recent file. Here's how you could do that.
' Only run if we actually have more than 14 files...
If oFolder.Files.Count > 14 Then
' Create an array to the hold the dates of each file in this folder...
ReDim a(oFolder.Files.Count - 1)
' Store the dates...
i = 0
For Each oFile In oFolder.Files
a(i) = oFile.DateLastModified ' Or use DateCreated, if you wish
i = i + 1
Next
' Sort the array...
Sort a
' Get the 14th most-recent date...
dtmCutOff = a(13)
' Iterate the files once more and delete any files older than our cut-off...
For Each oFile In oFolder.Files
If oFile.DateLastModified < dtmCutOff Then oFile.Delete
Next
End If
' Simple bubble sort...
Sub Sort(a)
For i = UBound(a) - 1 To 0 Step -1
For j = 0 To i
If a(j) > a(j + 1) Then
temp = a(j + 1)
a(j + 1) = a(j)
a(j) = temp
End If
Next
Next
End Sub
The only issue I think you'll have is if two files with the exact same date and time occupy the 14th position. Using this method, the script would keep both, and you'd end up with 15 files (or more, if there were more matches). But that's going to be an issue no matter what method you use. If your 20 most-recent files have the same date and time, how you do choose 14 from amongst those 20 to keep? =)
I have a serious problem with my VB 6 application. In it, I have a reference to wmp.dll in a Form, the idea it's play media video files, i have a ListView called LV1 in which I show the playlist filenames. I wish to know the current index from the current Playlist.
This sub is in charge of detecting the changes:
Private Sub Wmp1_CurrentItemChange(ByVal pdispMedia As Object)
I can get the totall count into the playlist with this line:
Val=Wmp1.currentPlaylist.Count
How I can obtain the current track (index) in reproduction, if i want coordinate this with my ListView, to select the same track with the same index into the playlist.
Thanks for your help.
You can use setItemInfo on the media before adding to currentPlaylist like this:
Option Explicit
Private Sub Form_Load()
Dim sFile As String
Dim oMedia As IWMPMedia
sFile = Dir("c:\temp\*.avi")
Do While LenB(sFile) <> 0
Set oMedia = Wmp1.newMedia("c:\temp\" & sFile)
oMedia.setItemInfo "Index", Wmp1.currentPlaylist.Count
Wmp1.currentPlaylist.appendItem oMedia
sFile = Dir
Loop
End Sub
Private Sub Wmp1_CurrentItemChange(ByVal pdispMedia As Object)
Debug.Print Wmp1.currentPlaylist.Item(Wmp1.currentMedia.getItemInfo("Index")).Name
End Sub
This is the answer. You have to search again in the loop
Dim i As Integer
For i = 0 To WindowsMediaPlayer1.currentPlaylist.Count - 1
If WindowsMediaPlayer1.currentPlaylist.Item(i).isIdentical(WindowsMediaPlayer1.currentMedia) = True Then Exit For
Next
List1.Selected(i) = True