VBA Kill Task

VBA to kill task in task manager by process name.  You need to lookup the process name in task manager so you can tell excel which task to kill.  In the below example Excel is killing task Max.exe process.

 

Function TaskKill(sTaskName)
TaskKill = CreateObject("WScript.Shell").Run("taskkill /f /im " & sTaskName, 0, True)
End Function
TaskKill "Max.exe"

VBA Change Default File Prompt Folder

VBA Change Default File Prompt Folder

Change the default folder that opens when VBA prompts user to select a file.  First you need to change to the Drive where the folder is stored. Below example is using X: drive location. Then change directory to the folder you want to open for the user.

ChDrive "X:\"
ChDir "X:\Data\Dev\Files"




'Button initiate process

Private Sub Command4_Click()
 Dim Report As String
 Dim Folders As Outlook.Folders
 Dim folder As Outlook.folder
 Dim reply As Integer
 Dim NameSpaceObj As Outlook.Namespace: Set NameSpaceObj = GetNamespace("MAPI")
 Dim BaseFolder As Outlook.MAPIFolder
 Set BaseFolder = NameSpaceObj.GetDefaultFolder(olFolderInbox)
 Dim Item As Object
 Dim FolderIndex() As String



folderType = "Personal"
 
 i = 0
 ReDim FolderIndex(0)
 For Each Item In BaseFolder.Folders
 If TypeOf Item Is Outlook.folder Then
 FolderIndex(i) = Item.Name
 i = i + 1
 ReDim Preserve FolderIndex(i)
 End If
 Next
 
 Dim myUserForm As UserForm1
 Set myUserForm = New UserForm1
 On Error Resume Next

'myUserForm.ListBox1.MultiSelect = 1
 myUserForm.ListBox1.List = FolderIndex
 myUserForm.BaseFolder = ""
 myUserForm.folderType = folderType
 myUserForm.Show
End Sub



'Form

TextBox1

ListBox1



'Form button

Private Sub SubmitForm_Click()
 Dim objNS As Outlook.Namespace
 Dim objFolder As Outlook.MAPIFolder
 Dim TextToWrite As String
 Dim Report As String
 Dim Folders As Outlook.Folders
 Dim folder As Outlook.folder
 Dim reply As Integer
 Dim j, jj As Long
 j = 0
 jj = 0
 Set objNS = GetNamespace("MAPI")
 If folderType = "Public" Then
 Set objFolder = objNS.GetDefaultFolder(olPublicFoldersAllPublicFolders)
 Else
 Set objFolder = objNS.GetDefaultFolder(olFolderInbox)
 End If
 If BaseFolder <> "" Then
 For Each i In Split(BaseFolder, "==>")
 Set objFolder = objFolder.Folders(i)
 Next
 End If
 TextToWrite = "Subject" + "|" + _
 "Body" + "|" + _
 "FromName" + "|" + _
 "ToName" + "|" + _
 "CCName" + "|" + _
 "BCCName" + "|" + _
 "Categories" + "|" + _
 "Importance" + "|" + _
 "Sensitivity" + "|" + _
 "Attachment Name" + "|" + _
 "Sent Date" + "|" + _
 "Received Date"

For j = 0 To ListBox1.ListCount - 2
 If ListBox1.Selected(j) = True Then
 Set objFolderTwo = objFolder.Folders(ListBox1.List(j))
 For Each Item In objFolderTwo.Items
 If TypeOf Item Is Outlook.MailItem Then
 Dim currentMail As Outlook.MailItem: Set currentMail = Item
 TextToWrite = TextToWrite + vbNewLine + currentMail.Subject
 TextToWrite = TextToWrite + "|" + Replace(Replace(currentMail.Body, vbNewLine, "\n"), "|", " ")
 TextToWrite = TextToWrite + "|" + currentMail.SenderName
 TextToWrite = TextToWrite + "|" + currentMail.To
 TextToWrite = TextToWrite + "|" + currentMail.CC
 TextToWrite = TextToWrite + "|" + currentMail.BCC
 TextToWrite = TextToWrite + "|" + currentMail.Categories
 TextToWrite = TextToWrite + "|" + CStr(currentMail.Importance)
 TextToWrite = TextToWrite + "|" + CStr(currentMail.Sensitivity) + "|"
 If currentMail.Attachments.Count > 0 Then
 For Each Attachment In currentMail.Attachments
 TextToWrite = TextToWrite + Attachment + ", "
 Next
 End If
 TextToWrite = TextToWrite + "|" + CStr(currentMail.SentOn)
 TextToWrite = TextToWrite + "|" + CStr(currentMail.ReceivedTime)
 End If
 Next
 End If

Next j
 nameOfFile = "Z:\" & TextBox1.Value & ".csv"
 Set fso = CreateObject("Scripting.FileSystemObject")
 Set out = fso.CreateTextFile(nameOfFile, True, True)
 out.WriteLine (TextToWrite)
 out.Close
 Unload Me
 SysCmd acSysCmdRemoveMeter
 
 DoCmd.SetWarnings (warningsOff)
 DeleteTblStrSql = "DELETE EmailData.* FROM EmailData;"
 DoCmd.RunSQL (DeleteTblStrSql)
 DoCmd.TransferText acImportDelim, "Pipe", "EmailData", "Z:\" & TextBox1.Value & ".csv"
 ' Print #300, TextToWrite
 ' Close #300
 Unload Me
End Sub




dfagfda

fd
'Subfolder button

Private Sub SeeSubFolders_Click()
 Dim NameSpaceObj As Outlook.Namespace: Set NameSpaceObj = GetNamespace("MAPI")
 Dim StartFolder As Outlook.MAPIFolder
 Dim FolderIndex() As String
 If folderType = "Public" Then
 Set StartFolder = NameSpaceObj.GetDefaultFolder(olPublicFoldersAllPublicFolders)
 Else
 Set StartFolder = NameSpaceObj.GetDefaultFolder(olFolderInbox)
 End If
 i = 0
 ReDim FolderIndex(0)
 For j = 0 To ListBox1.ListCount - 2
 If ListBox1.Selected(j) = True Then
 If BaseFolder = "" Then
 Set StartFolder = StartFolder.Folders(ListBox1.List(j))
 BaseFolder = ListBox1.List(j)
 Else
 BaseFolder = BaseFolder & "==>" & ListBox1.List(j)
 For Each i In Split(BaseFolder, "==>")
 Set StartFolder = StartFolder.Folders(i)
 Next
 End If
 For Each Item In StartFolder.Folders
 FolderIndex(i) = Item.Name
 i = i + 1
 ReDim Preserve FolderIndex(i)
 Next
 ListBox1.List = FolderIndex
 End If
 Next
End Sub

VBA to add all files in a folder to an email

Add all files in folder to an email

VBA that will add all files in folder to an email.  Loops the folder and attaches each file to the email.

 

Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)
With OutMail
 .To = "Dylan.Gregory@vba-market.com"
 .CC = "CC@email.com"
 .Subject = "Subject Line"
 .HTMLBody = "Add all attachements in folder … "
 strPath = "Z:\My Documents\tempFolder\"
 StrFile = Dir(strPath & "*.*")
 Do While Len(StrFile) > 0
 .Attachments.Add strPath & StrFile
 StrFile = Dir
 Loop

.display
End With

Access VBA to run an Excel Macro from Access

Access VBA to run an Excel Macro from Access

This VBA will run an Excel macro from Access.  The VBA exports a designated Access table to Excel and then runs a macro from Excel.  Allows you to manipulate data from an Access table using an Excel macro.  Then you can have the macro save the file, write back to the Access Table or anything else you can think of.

*Update the MySQL SELECT statement with your table name.

*Update MySheetPath with your Excel file

* Update Set XlSheet = XlBook.Worksheets("MasterList") with the Excel Sheet name where you want to import your Access table to.

*Update Xl.Run ("ExcelMacroName") with the name of the macro you want Access to run.

Dim MyRecordSet As New ADODB.Recordset
Set cnn = CurrentProject.Connection
MyRecordSet.ActiveConnection = cnn

MySQL = "SELECT Table1.* FROM Table1;"
MyRecordSet.Open MySQL

MySheetPath = "Z:\My Documents\FileName.xlsm"
MsgBox "Please open Excel. Once open, press the OK button below", vbOKOnly, "Open Excel"
Set Xl = GetObject(, "Excel.Application")
Set MyCurrentDb = CurrentDb
Set XlBook = GetObject(MySheetPath)

Xl.Visible = True
XlBook.Windows(1).Visible = True

Set XlSheet = XlBook.Worksheets("MasterList")

XlSheet.Range("A2").CopyFromRecordset MyRecordSet

XlBook.Activate

Xl.Run ("ExcelMacroName")

XlBook.Close (False)

VBA to have macro wait

Excel VBA wait:

Application.Wait (Now + TimeValue("00:00:02"))
 

Access VBA wait:

WaitUntil = Now + TimeValue("00:00:05")
 Do
 DoEvents
 Loop Until Now >= WaitUntil

 


Format number with leading zero's

One of the most efficient ways I've found to format a number with leading zero's.

Excel: =Right("000000000" & C2, 9)

Access:  Right("000000000" & [Tbl_All_Accounts]![AccountNumber],9)


Excel VBA get Access database table data

Excel VBA get Access database table data

This Excel VBA will connect to an Access database and loop the designated Table.  Update Data Source with the path to your Access Database and then update rs.Open"Table1" with your Table's name.

 

 

Sub GetDBData()

Set cn = New ADODB.Connection
cn.Open "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=Z:\My Documents\Database1.accdb;"
Set rs = New ADODB.Recordset
rs.Open "Table1", cn, adOpenKeyset, adLockOptimistic, adCmdTable
 rs.MoveLast
 rws = rs.RecordCount
 rs.MoveFirst
 
 
 Do While Not rs.EOF
 val1 = rs("Field1")
 MsgBox "Table1 value =" & val1
 rs.MoveNext
 Loop
 rs.Close



End Sub

Access VBA get record count in table

Access VBA to count the number of records in table.  Message box will say how many records are in table.

 

Dim db As DAO.Database
Set db = CurrentDb
strSQL = "SELECT Table1.* FROM Table1;"
 On Error Resume Next
 db.QueryDefs.Delete "CountList"
 On Error GoTo 0
 Set NewCountList = db.CreateQueryDef("CountList", strSQL)
 Set RstAcct = db.OpenRecordset("CountList")
 RstAcct.MoveLast
 x = RstAcct.RecordCount
 If RstAcct.EOF Then
 MsgBox "table is blank"
else
   msgbox "There are " & x & " number of records"
 End If

Access VBA Export table to excel

Access VBA Export table to excel

Access VBA to export a table to excel.  CreateQueryDef creates a temporary query to SELECT the data from the table and Docmd.TransferSpreadsheet exports the data to Excel.  Update xlFileSaveName with the path for where you want the Excel to save to and update the SELECT query "SQLMasterPage" with your table name.

Dim db As DAO.Database
Set db = CurrentDb
 On Error Resume Next
    db.QueryDefs.Delete "ExportTempQuery"
 On Error GoTo 0
 xlFileSaveName = "Z:\Dylan\export.xls"
 SQLMasterPage = "SELECT Table1.* FROM Table1"
 Set MasterPage = db.CreateQueryDef("ExportTempQuery", SQLMasterPage)
 DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel7, "ExportTempQuery", xlFileSaveName, True