Regards. I am looking for a code in VBA that allows me, in the RESOURCE USAGE view, to go through the resources with assignment in the ResourceField with a FOR NEXT, and extract their assignment information from the TimescaleRange (right panel with tabular information), in order to be able to format the information and export it upon decision.
Capture of the RESOURCE USAGE view
I expand a little the information of my concern... in the capture I present the Resource Usage view, I take that information and with the list of resources on the left, I copy and paste it in excel; With this information I create my resource histogram, but I want to generate the export process through a VBA macro since there are several steps to perform (filtering, organizing the timeline of the view, and exporting the information of start to finish).
This code will loop through the resources in the active project and get work hours by resource by week.
Sub GetWorkByResourceByAssignment()
Dim dteStart As Date
Dim dteEnd As Date
dteStart = #5/24/2021#
dteEnd = #8/2/2021#
Dim res As Resource
Dim a As Assignment
Dim tsvs As TimeScaleValues
Dim tsv As TimeScaleValue
For Each res In ActiveProject.Resources
For Each a In res.Assignments
Set tsvs = a.TimeScaleData(StartDate:=dteStart, _
EndDate:=dteEnd, _
Type:=pjAssignmentTimescaledWork, _
TimeScaleUnit:=pjTimescaleWeeks)
ReDim workHours(tsvs.Count) As Long
Dim strValues As String
strValues = vbNullString
Dim i As Integer
i = 0
For Each tsv In tsvs
i = i + 1
workHours(i) = Val(tsv.Value) / 60
strValues = strValues & ", " & workHours(i)
Next tsv
Debug.Print res.Name, a.Task.Name, strValues
Next
Next
End Sub
The variable strValues and the debug statement are for demonstration purposes. The array workHours contains the numeric representation of the hours which can be used for the histogram.
Related
I have a code that can automaticaly move a PDF from a received message to a folder of my choice, but what I really need is in fact to be able to move a file to a specific folder depending of the sender.
The code below works for only one sender, How do I add more senders and more folder locations?
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub Items_ItemAdd(ByVal item As Object)
On Error GoTo ErrorHandler
'Only act if it's a MailItem
Dim Msg As Outlook.MailItem
If TypeName(item) = "MailItem" Then
Set Msg = item
'Change variables to match need. Comment or delete any part unnecessary.
If (Msg.SenderName = "Marc, Test") And _
(Msg.Subject = "Heures") And _
(Msg.Attachments.Count >= 1) Then
'Set folder to save in.
Dim olDestFldr As Outlook.MAPIFolder
Dim myAttachments As Outlook.Attachments
Dim Att As String
'location to save in. Can be root drive or mapped network drive.
Const attPath As String = "C:\Users\NAEC02\Test\"
' save attachment
Set myAttachments = item.Attachments
Att = myAttachments.item(1).DisplayName
myAttachments.item(1).SaveAsFile attPath & Att
' mark as read
Msg.UnRead = False
End If
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
Before answering your question, some comments on your existing code.
You are running this code within Outlook. You do not need olApp. You only need a reference to the Outlook application if you are trying to access your emails from Excel or some other Office product.
I am surprised how often I see On Error GoTo ErrorHandler because I have never found a use from this statement.
If I am coding for myself, I want execution to stop on the statement causing the problem so I can understand what is happening without guessing from the error message. If execution stops on the statement causing the error, I can restart the code if I can immediately fix the error.
If I am developing for a client, I want, at worst, a user-friendly message. Err.Number & " - " & Err.Description is not my idea of a user-friendly message. It does not even tell me which email caused the problem. For a client, I would have something like:
Dim ErrDesc as String
Dim ErrNum as Long
: : :
On Error Resume Next
Statement that might give an error
ErrNum = Err.Num
ErrDesc = Err.Description
On Error GoTo 0
If ErrNum <> 0 Then
Code to handle errors that can occur with
this statement in a user-friendly manner.
End If
Today Dim Att As String is fine because you remember what Att is. Will you remember when you update this macro in six or twelve months? Will a colleague updating this macro know what Att is? I would call it AttName or perhaps AttDsplName.
You say the code saves PDF attachments but you do not check for this. To a VBA macro, logos, images, signatures and other files are also attachments. Also you assume the attachment you wish to save is Attachments(1). If there are several attachments, the logos, images and signatures could come first.
You have:
'Set folder to save in.
Dim olDestFldr As Outlook.MAPIFolder
You do not set olDestFldr and you do not move the email to a different folder. Do you want to do this?
Now to your question. I have included the code for two methods of achieving your objective and I discuss another two methods. However, before showing you the code, I suspect I need to introduce you to Variants. Consider:
Dim A As Long
Dim B As String
Dim C As Double
Dim D As Variant
I have declared A to C as a long integer, a string and a double. These variables can never be anything else and must be used in accordance with the rules for their type. I can write A = A + 1 or A = A * 5. Providing the new value for A does not exceed the maximum value for a long integer, these statements are fine. But I cannot write A = "House" because "House" is not an integer. I can write B = "House" because "House" is a string. I can write B = "5" and then A = A + B because VBA will perform implicit conversions if it can. That is, VBA can convert string "5" to integer 5 and add it to A.
I can also write:
D = 5
D = D + A
D = "House"
D is a Variant which means it can hold any type of data. Here I assign 5 to D then add A so for these two statements, D is holding an integer. I then change my mind and assign a string to D. This is not very sensible code but it is valid code. D can hold much more than an integer and a string. In particular, it can hold an array. Consider:
ReDim D(0 To 2)
D(0) = "House"
D(1) = A + 5
D(2) = 3.7
Following the ReDim statement, it is as though D has been converted to an array and I use array syntax to access the elements of D. D(0) contains "House", D(1) contains 5 more than the current value of A and D(2) contains double 3.7.
I can achieve the same effect with:
D = Array("House", A + 5, 3.7)
I am sure you agree this is easier. Array is a function that can take a large number of parameters and returns a Variant array containing those parameters which I have assigned to D. I do not normally advise mixing types within a variant array since it is very easy to get yourself into a muddle. However, it is valid VBA and I have found it invaluable with particularly difficult problems. Normally, I would not use function Array, I would write:
D = VBA.Array("House", A + 5, 3.7)
With VBA.Array, the lower bound of the array is guaranteed to be zero. With Array, the lower bound depends on the Option Base statement. I have never seen anyone use the Option Base statement, but I do not like to risk having my code changed by someone adding this statement. Search for “VBA Option Base statement” to discover what this statement does.
The following code demonstrates my first method of achieving your objective:
Option Explicit
Sub Method1()
Dim DiscFldrCrnt As Variant
Dim DiscFldrs As Variant
Dim Inx As Long
Dim SenderNameCrnt As Variant
Dim SenderNames As Variant
Dim SubjectCrnt As Variant
Dim Subjects As Variant
SenderNames = VBA.Array("Doe, John", "Early, Jane", "Friday, Mary")
Subjects = VBA.Array("John's topic", "Jane's topic", "Mary's topic")
DiscFldrs = VBA.Array("DoeJohn", "EarlyJane", "FridayMary")
For Inx = 0 To UBound(SenderNames)
SenderNameCrnt = SenderNames(Inx)
SubjectCrnt = Subjects(Inx)
DiscFldrCrnt = DiscFldrs(Inx)
' Code to process SenderNameCrnt, SubjectCrnt and DiscFldrCrnt
Debug.Print SenderNameCrnt & " " & SubjectCrnt & " " & DiscFldrCrnt
Next
End Sub
If you copy this code to a module, you can run it and see what it does. If you work slowly through it, you should be able to understand what it is doing. Come back with questions if necessary but the more you can discover for yourself, the faster you will develop your own skills.
Note: the disc folders have names such as “DoeJohn”. I am assuming you would have something like "C:\Users\NAEC02\Test\" as a root folder and you would save the attachment to "C:\Users\NAEC02\Test\DoeJohn\".
I use this method when I have a small number of values I need to link. It relies on SenderNames(#), Subjects(#) and DiscFldrs(#) being associated. As the number of different combinations increase, it can be difficult to keep the three arrays in step. Method2 solves that problem.
Sub Method2()
Dim DiscFldrCrnt As Variant
Dim Inx As Long
Dim SenderNameCrnt As Variant
Dim SubjectCrnt As Variant
Dim TestValues As Variant
TestValues = Array("Doe, John", "John's topic", "John", _
"Early, Jane", "Jane's topic", "Jane", _
"Friday, Mary", "Mary's topic", "Mary")
For Inx = LBound(TestValues) To UBound(TestValues) Step 3
SenderNameCrnt = TestValues(Inx)
SubjectCrnt = TestValues(Inx + 1)
DiscFldrCrnt = TestValues(Inx + 2)
' Code to process SenderNameCrnt, SubjectCrnt and DiscFldrCrnt
Debug.Print SenderNameCrnt & " " & SubjectCrnt & " " & DiscFldrCrnt
Next
End Sub
Here I have placed all the values in a single array. If I want to add a new sender, I add another three elements to the end of the array which I find this easier to manage. For the code to process the three values, Method1 and Method2 are identical.
The principle disadvantage of Method2 compared with Method1 is that the total number of values is reduced. I like to see all my code so I do not like statements that exceed the width of the screen. This limits my lines to about 100 characters. I use the continuation character to spread the statement over several lines but there is a maximum of 24 continuation lines per statement. With Method1, I am spreading the values over three arrays and therefore three statements so I can have three times as many values. In practice this is not a real limit. Both Method1 and Method2 become too difficult to manage before the VBA limits are reached.
The real disadvantage of Method1 and Method2 is that every change requires the services of a programmer. If user maintenance is important, I use Method3 which reads a text file into arrays or Method4 which reads from an Excel worksheet. I have not included code for either Method3 or Method4 but can add one or both if you need this functionality. I find most users prefer a worksheet but those with a favourite text editor prefer a text file.
In the middle of both Method1 and Method2 I have:
' Code to process SenderNameCrnt, SubjectCrnt and DiscFldrCrnt
Debug.Print SenderNameCrnt & " " & SubjectCrnt & " " & DiscFldrCrnt
You need to replace these statements with a variation of your existing code. I have no easy method of testing the following code so it is untested but it should give you are start.
This is a new version of Items_ItemAdd designed to work with either of my methods.
Private Sub Items_ItemAdd(ByVal Item As Object)
Const DiscFldrRoot As String = "C:\Users\NAEC02\Test\"
' * There is no need to write Outlook.MailItem because (1) you are within Outlook
' and (2) there is no other type of MailItem. You only need to specify Outlook
' for folders since there are both Outlook and Scripting folders. Note:
' "Scripting" is the name of the library containing routines for disc folders.
' * Do not spread your Dim statements throughout your sub. There are languages
' where you can declare variables within code blocks but VBA is not one of those
' languages. With VBA, you can declare variables for an entire sub or function,
' for an entire module or for an entire workbook. If you spread your Dim
' statements out it just makes them hard to find and you are still declaring
' them at the module level.
Dim DiscFldrCrnt As Variant
Dim InxA As Long
Dim Msg As MailItem
Dim SenderNameCrnt As Variant
Dim SubjectCrnt As Variant
' You also need the arrays from whichever of Method1 or Method2 you have chosen
If TypeName(item) = "MailItem" Then
' Only interested in MailItems
Set Msg = Item
' Code from Method1 or Method2 with the code below in the middle
End If
End Sub
Insert the body of Method1 or Method2, whichever you chose, in the middle of the above code. Then insert the following code in the middle of that code.
With Msg
If .Attachments.Count = 0 Then
' Don't bother to check MailItem if there are no attachments
Else
If .Subject <> SubjectCrnt Then
' Wrong subject so ignore this MailItem
ElseIf .SenderName <> SenderNameCrnt Then
' Wrong sender name so ignore this MailItem
Else
' SenderName and Subject match so save any PDF attachments
For InxA = 1 to .Attachments.Count
If LCase(Right$(.Attachments(InxA).DisplayName, 4)) = ".pdf" Then
' Warning: SaveAsFile overwrites existing file with the same name
.Attachments(InxA).SaveAsFile DiscFldrRoot & DiscFldrCrnt & _
.Attachments(InxA).DisplayName
End If
End With
Next
End If
End With
I need to search the file system (a drive usually) for a fully defined file path while given only a fragment of the file name.
The fragment is actually the part number of the part, and the files to search are all of type '.idw'. Further, they are named with a series that helps sort them; ie 1XX-XXXX.idw, 2XX-XXX.idw.
There are 50,000+ files and just using a FileScriptingObject and recursive reading each folder then comparing them takes something like 2 minutes per search.
(Given a list of part numbers, I need to populate a column in Excel with the full file name)
I'm guessing my best way to go about this is to generate an indexed list of all of the idw files I'm looking for, reducing the full file string to only the base name and using that as the key. However, this would still required the timely run at the start of each search assuming I use this dictionary/collection/list over and over per run.
Is there any way to store a dictionary in an external file, so I can generate the indexed list once per day or a lot less frequently?
Otherwise, is there a better way to do this with VBA that I have not thought of?
Following up the comment from #omegastripes, you can combine three methods to achieve the objective.
Use the Exec method of WScript.Shell to run a Dir command - likely faster than using FileSystemObject
Split the StdOut to get a Variant array of all the filenames returned - this is the one-time hit to get the list of files you want to search over
Use the Filter function to reduce the array to just the filenames including the ones you are interested in displaying on the spreadsheet.
The DIR command leverages some switches that are important to the task:
/S - recursive through sub-directories
/B - bare names only
/A:-D - exclude directories from output, i.e. files only
Here's the sample code:
Option Explicit
Sub Test()
Dim arrFiles As Variant
Dim arrSearchTerms As Variant
Dim arrMatches As Variant
Dim intTargetCounter As Integer
Dim intMatchCounter As Integer
'get files
arrFiles = GetFileList("C:\WINDOWS", "idw")
If UBound(arrFiles) = 0 Then
MsgBox "No files found"
Exit Sub
End If
'iterate search terms and check collection
arrSearchTerms = Array("1XX-XXXX", "2XX-XXXX")
For intTargetCounter = LBound(arrSearchTerms) To UBound(arrSearchTerms)
arrMatches = Filter(arrFiles, arrSearchTerms(intTargetCounter))
For intMatchCounter = LBound(arrMatches) To UBound(arrMatches)
Debug.Print arrMatches(intMatchCounter)
Next intMatchCounter
Next intTargetCounter
End Sub
Function GetFileList(strRoot As String, strExtensionFilter As String) As Variant
Dim objShell As Object
Dim strCommand As String
Dim objShellExe As Object
On Error GoTo CleanUp
'call cmd
Set objShell = CreateObject("WScript.Shell")
strCommand = "%COMSPEC% /C DIR /S /B /A:-D *." & strExtensionFilter
objShell.CurrentDirectory = strRoot
Set objShellExe = objShell.Exec(strCommand)
'wait for listing
While objShellExe.Status <> 1
DoEvents
Wend
'convert std out to array
GetFileList = Split(objShellExe.StdOut.ReadAll, vbCrLf)
CleanUp:
If Err.Number <> 0 Then
Debug.Print Err.Number & ": " & Err.Description
End If
Set objShellExe = Nothing
Set objShell = Nothing
End Function
As a part of a database that i am developing i have a function that i developed in Access 2010 . on presenting it to my Superiors i was asked to enhance the presentation or Display. i am just hoping someone can Point me the right direction..
so basically i am inserting some values from one table to the other. but i first run Loops to determine which field names match and copy from the Import table only those fields which match for the target table. so far it works perfectly. no Problems. i am displaying the matching field names in a msg box. the code for this field Name comparision is as follows:
Private Sub Command50_Click()
Dim n As Long
Dim m As Long
Dim Ret_Type As Integer
Dim str As String
Dim stp As String
Dim mystr As String
Dim mysas As String
Dim rs As DAO.Recordset
Dim rs1 As DAO.Recordset
Set rs = CurrentDb.OpenRecordset("MLE_Table")
Set rs1 = CurrentDb.OpenRecordset("tbl_Import")
With rs
For n = 0 To .Fields.Count - 1
str = CurrentDb().TableDefs("MLE_Table").Fields(n).Name
With rs1
For m = 0 To .Fields.Count - 1
stp = CurrentDb().TableDefs("tbl_Import").Fields(m).Name
Debug.Print stp
If str = stp Then
mystr = mystr & str & ", "
fnd = True
Exit For
End If
Next m
If Not fnd Then mysas = mysas & str & vbCrLf
fnd = False
End With
Next n
.Close
End With
Ret_Type = MsgBox("The Following Fields could not be found in your upload !!" & vbCrLf & mysas, vbOKOnly + vbExclamation, " MISSING DATA")
End Sub
now what my colleagues want is that this msg box is not sufficient.. they want a more detailed Display. maybe a form or a text file or something so that the user has a more clear Picture.
the Suggestion was to Show up all the fields of the target table and then Show the fields that matched as green or maybe a tick or checkmark.
i am sure this cannot be done in a msgbox. i know it sounds elegant and i am not sure it can be done. some colleagues say it can be.
can somebody Point me in the right direction or some Suggestion please. i am not experianced enough in Access, so this would be a learning experiance..
thanks in advance..
What I like to do when I want to show text or data that doesn't fit into a MsgBox (or isn't suitable), is to paste it to a new Notepad window:
Shell "notepad", vbNormalFocus
ClipBoard_SetData strText ' google this function
SendKeys "^V", True
Or if it's tabular data, I open Excel and write it to a new sheet.
Starting a separate application has the additional advantage that users can easily save the data, if necessary.
I would like to create a program in Excel that loops through a list of Access databases and writes the VBA that exists in the Access modules. I have found some code that I can run from Access which writes the VBA that exists in the Access modules. I am trying to figure out how to reference the database files from Excel and run the program on each database file. I will probably be able to figure out how to loop through the database files. I just need help with referencing the database file in the below code.
I can open the database with something like this:
Dim cstrDbFile As String = "C:\Database51.accdb"
Dim objShell As Object
Set objShell = CreateObject("WScript.Shell")
objShell.Run cstrDbFile
I also tried to set up a reference to Access like this:
Dim appAccess As Object
Set appAccess = CreateObject("Access.Application")
appAccess.OpenCurrentDatabase ("C:\Database51.accdb")
I need to figure out how to refer to the Access database in:
Application.VBE.ActiveVBProject.VBComponents
I probably need to figure out how to create a reference to replace ActiveVBProject.
Below is some code I found which writes the contents of VBA modules. I don't remember where I found it.
For Each Component In Application.VBE.ActiveVBProject.VBComponents
With Component.CodeModule
'The Declarations
For Index = 1 To .CountOfDeclarationLines
Debug.Print .Lines(Index, 1)
Next Index
'The Procedures
For Index = .CountOfDeclarationLines + 1 To .CountOfLines
Debug.Print .Lines(Index, 1)
Next Index
End With
Next Component
The following code will let you see Access database objects, but I don't know how to export the code (DoCmd not in Excel?). Your task would be VERY simple to do from Access, so I would reconsider...
Option Explicit
' Add a reference to the DAO Object Library
Sub Read_Access_VBA()
Dim dbs As DAO.Database
Dim ctr As DAO.Container
Dim doc As DAO.Document
Dim iC As Integer
Dim iD As Integer
Dim i As Integer
Dim mdl As Module
Set dbs = DBEngine.OpenDatabase("c:\TEMP\106thRoster.mdb", False, False, _
"MS Access;")
Debug.Print "----------------------------------------"
For iC = 0 To dbs.Containers.Count - 1
Debug.Print "Container: " & dbs.Containers(iC).Name
If dbs.Containers(iC).Documents.Count > 0 Then
For iD = 0 To dbs.Containers(iC).Documents.Count - 1
Debug.Print vbTab & "Doc: " & dbs.Containers(iC).Documents(iD).Name
Next iD
Else
Debug.Print " No Documents..."
End If
Next iC
'Set ctr = dbs.Containers!Modules
dbs.Close
Set doc = Nothing
Set ctr = Nothing
Set dbs = Nothing
End Sub
I was able to find some code that will assist me with my final goal: Exporting MS Access Forms and Class / Modules Recursively to text files?
Below are the most significant lines that will allow me to make progress with the project.
LineCount = oApp.Forms(Name).Module.CountOfLines
FileName = Path & "\" & Name & ".vba"
F = FreeFile
Open FileName For Output Access Write As #F
Print #F, oApp.Forms(Name).Module.Lines(1, LineCount)
Close #F
After learning that MS Access only allows absolute addressing for its linking of tables and that the only workaround for this problem was throught the use of VBA code I started coding up a way for it to do so. I found a relatively simple code and modified to suit my purpose which you can see below. However this method seems to have 2 main problems.
1 - I can't seem to link Excel Spreedsheets, as the first attempt lead to my whole module corrupting itself. Is there a way to link them as well?
2 - More importantly the size of the file increases each time it is open and the only modification to the database has been the addition of the code within the module. I've made it so it automatically executes upon opening of the file and after closing I've noticed it increases in size by several 100 kbs. Which is disturbing.
Also if there is a better method of doing this I'd be very interested in seeing how its done.
Public Sub RelinkTables(newPathName As String, backEnd As String, excel1 As String, excel2 As String)
Dim Dbs As Database
Dim Tdf As TableDef
Dim Tdfs As TableDefs
Set Dbs = CurrentDb
Set Tdfs = Dbs.TableDefs
'Loop through the tables collection
For Each Tdf In Tdfs
If Tdf.SourceTableName <> "" Then 'If the table source is other than a base table
If Tdf.SourceTableName = "CClas$" Or Tdf.SourceTableName = "Sheet1$" Then
Else
Tdf.Connect = ";DATABASE=" & newPathName & backEnd 'Set the new source
Tdf.RefreshLink 'Refresh the link
End If
End If
Next 'Goto next table
End Sub
Function ReLinker()
Dim currPath As String
Dim backEnd As String
Dim excel1 As String
Dim excel2 As String
currPath = CurrentProject.Path
Debug.Print currPath
backEnd = "\backEnd.accdb"
excel1 = "\excel1.xls"
excel2 = "\excel2.xls"
RelinkTables currPath, backEnd, excel1, excel2
End Function
"the size of the file increases each time it is open"
That makes sense. Relinking normally increases the size of your db file. And since you're relinking again every time you open the db, you should expect that size increase. Perform a compact to shrink the db file back down again.
However, I would examine the existing links and only perform the relink if they need changing.
Also, consider verifying that your link file targets are present before proceeding with the relink.
If Len(Dir(currPath & backEnd)) = 0 _
Or Len(Dir(currPath & excel1)) = 0 _
Or Len(Dir(currPath & excel2)) = 0 Then
MsgBox "Oops!"
End If
For the Excel links, see if you can build on any of the following ...
? CurrentDb.TableDefs("tblExcelData").Connect Like "Excel*"
True
? CurrentDb.TableDefs("tblExcelData").Connect
Excel 8.0;HDR=YES;IMEX=2;DATABASE=C:\share\Access\temp.xls
? Split(CurrentDb.TableDefs("tblExcelData").Connect, "DATABASE=")(1)
C:\share\Access\temp.xls