VBA - auto-mate/CheatSheetWiki GitHub Wiki
DSN Less Access SQL Connection
Excel Git
Include Method
InternetExplorer Object Notes
outlook not spam confirmation - See Powershell
References
Snippets
InternetExplorer Object Notes
Try InternetExplorerMedium instead where disconnection occuring
References
In Access you may need to remove references before closing so that opening in say Access 2010 a database saved in 2013 Missing References won't exist that are difficult to remove.
i.e. Run below before closing
Sub clearVBRefs()
'// On Close Removes all refs so that missing refs don't cause an issue
On Error Resume Next
Set refColl = VBE.ActiveVBProject.References
For n = Application.VBE.ActiveVBProject.References.Count To 1 Step -1
If Application.VBE.ActiveVBProject.References(n).BuiltIn = False Then
Application.VBE.ActiveVBProject.References.Remove (refColl(n))
End If
Next
End Sub
On startup Load Refs
As an example create an array of Refs in AddRequiredRefs() then
pass the array of full file paths to loadPassedRefs(RefsArr()) to add the set in the Passed Array.
To list the Current array use:-
For n=1 to Application.VBE.ActiveVBProject.References.Count:Debug.Print Application.VBE.ActiveVBProject.References(n).FullPath :next
NB Can Use Application.Version to determine what to send if using file with multiple office versions. (Not Shown)
e.g.
Sub AddRequiredRefs()
Dim refColl As Object
Dim Refs(10)
Set refColl = VBE.ActiveVBProject.References
Refs(0) = "C:\PROGRA~2\COMMON~1\MICROS~1\VBA\VBA7\VBE7.DLL"
Refs(1) = "C:\Program Files (x86)\Microsoft Office\Office14\MSACC.OLB"
Refs(2) = "C:\Windows\SysWOW64\stdole2.tlb"
Refs(3) = "C:\Program Files (x86)\Common Files\Microsoft Shared\OFFICE14\ACEDAO.DLL"
Refs(4) = "C:\WINDOWS\SysWOW64\mshtml.tlb"
Refs(5) = "UIAutomationCore.dll"
Refs(6) = "C:\Windows\SysWOW64\ieframe.dll"
'// Load EXCEL Where Machines May be Running Office15 or 14
'// ########################################################
If Dir("C:\Program Files (x86)\Microsoft Office\Office15\EXCEL.EXE") <> "" Then
Refs(7) = "C:\Program Files (x86)\Microsoft Office\Office15\EXCEL.EXE"
Else
Refs(7) = "C:\Program Files (x86)\Microsoft Office\Office14\EXCEL.EXE"
End If
'// Load OUTLOOK Where Machines May be Running Office15 or 14
'// #########################################################
If Dir("C:\Program Files (x86)\Microsoft Office\Office15\MSOUTL.OLB") <> "" Then
Refs(8) = "C:\Program Files (x86)\Microsoft Office\Office15\MSOUTL.OLB"
Else
Refs(8) = "C:\Program Files (x86)\Microsoft Office\Office14\MSOUTL.OLB"
End If
Refs(9) = "C:\Program Files (x86)\Common Files\microsoft shared\DAO\dao360.dll"
loadPassedRefs Refs
End Sub
Sub loadPassedRefs(RefsArr())
On Error Resume Next
Dim n As Integer
For n = 1 To UBound(RefsArr)
Application.VBE.ActiveVBProject.References.AddFromFile (RefsArr(n))
Next
End Sub
Snippets
API in VB
Call Back API
AddressOf procedurename ( causes the address of the procedure it precedes to be passed to an API procedure that expects a function pointer )
Sleep
Private Declare Sub Sleep Lib "kernel32" Alias "Sleep" (ByVal dwMilliseconds As Long)
Common Classes
Use CreateObject("") with ..
Outlook.Application
Excel.Application
Word.Application
Powerpoint.Application
Access.Application
Wscript.Shell
Dim X as New ...
InternetExplorer (Turn Off Enable Protected Mode if dissconnection!)
IE Browser Via VBA
Run Javascript in IE browser [Existing and Injected]
Sub OpenBrowserAndRunInjectedJavaScript()
'NB Add Refs Internet Controls IEFrame.dll AND HTML Object Library mshtml.tlb
'----------------------------------------------------------------------------
'Run Injected Script
'-------------------
Dim ie As New InternetExplorer, doc As HTMLDocument: ie.Visible = True: ie.Navigate2 "www.bbc.co.uk"
Do While ie.readyState <> READYSTATE_COMPLETE: DoEvents: Loop: Set doc = ie.document
doc.parentWindow.execScript "alert('OK');", "Javascript"
'Run Known Function (Here In a Frame)
'------------------------------------
ie.Navigate2 "https://www.w3schools.com/js/tryit.asp?filename=tryjs_whereto_external"
Do While ie.readyState <> READYSTATE_COMPLETE: DoEvents: Loop
Set doc = ie.document
doc.frames("iframeResult").execScript "myFunction();", "Javascript"
ie.Quit
End Sub
ADO
ADO WildCard
Not Just JavaScript but [ U S E % N O T * ] when using LIKE in Access even if query saved in Access!
ADO Access in IE Javascript
**** Get Recordset from MSAccess as Javascript Array For File "C:\FolderA\FolderB\..\...DatabaseName.accdb" And PASSWORD='password' [IE Only]
function ReadAccess(sql) {var adoConn = new ActiveXObject("ADODB.Connection");
var adoRS = new ActiveXObject("ADODB.Recordset");
try {adoConn.Open("Provider=Microsoft.ACE.OLEDB.12.0;Data Source='C:\\FolderA\\FolderB..\\..\\DatabaseName.accdb';Jet OLEDB:Database Password='password'");}
catch(err) {alert(err + "Login Error");}
adoRS.Open(sql, adoConn, 1, 3);
var fc = adoRS.Fields.Count;
ds=[];
while (adoRS.EOF==false)
{rs=[];
for (i=0;i<fc;i++)
{rc=adoRS.Fields(i).value.toString();
rs.push(rc);
}
ds.push(rs);
adoRS.moveNext();
}
adoRS.Close();
adoConn.Close();
return ds;
}
Other
Command Line Compile to exe
[Go To vbc.exe path then run]
vbc.exe /t:exe /debug+ /optionstrict+ /out:\\SomePathandOutFile.exe \\SomePathandInFile.vb
Conversions
Oct Conversion &O10 = 8
Hex Conversion &H10 = 16
Run external program and wait
Dim obj As Object: Set obj = CreateObject("Wscript.Shell"): obj.Run "cmd /C dir & pause", , True
Desktop Windows Re Tile
Dim x As New Shell32.Shell: x.CascadeWindows: x.TileHorizontally: x.TileVertically: x.ToggleDesktop:x.ShutdownWindows`
Formats
format(now(),"\Quarter Q DDDD-DDD-DD-MMMM-MMM-MM-M-YYYY HH:MM:SS \Week WW")=Quarter 2 Monday-Mon-10-April-Apr-04-4-2017 09:46:23 Week 15
format(1234567.20,"#,###,.00")=1234.57
NB Use Chr(34) Not " when using in code
Clear Access Nulls
Function NullRem(TableName As String)
Dim rcs As Recordset
Set rcs = CurrentDb.OpenRecordset("SELECT TOP 1 * FROM [" & TableName & "]")
If Not rcs.EOF Then 'Do ALL
For n = 0 To rcs.Fields.Count - 1
fldName = rcs.Fields(n).Name
Debug.Print "updating " & fldName: DoEvents
Select Case rcs.Fields(n).Type
'1 Bool
Case 1
' 4 Number Long Int
Case 4
SQL = "UPDATE [" & TableName & "] SET [" & fldName & "] = 0 WHERE [" & fldName & "] Is Null"
' 7 Number Double
Case 7
SQL = "UPDATE [" & TableName & "] SET [" & fldName & "] = 0 WHERE [" & fldName & "] Is Null"
' 8 Date/Time
Case 8
SQL = "UPDATE [" & TableName & "] SET [" & fldName & "] = #1/1/2000# WHERE [" & fldName & "] Is Null"
'10 Text
Case 10
SQL = "UPDATE [" & TableName & "] SET [" & fldName & "] = """" WHERE [" & fldName & "] Is Null"
End Select
CurrentDb.Execute (SQL)
Debug.Print "RecordsAffected [" & TableName & "].[" & fldName & "] = " & CurrentDb.RecordsAffected: DoEvents
Next
End If 'End Do ALL
End Function
SAP in VB
Find Element
sessionN.findById("ID").SelectAfunction
General Functions
.Maximize
.pressToolbarButton "&MB_VARIANT"
.pressToolbarContextButton "&MB_EXPORT"
.SelectContextMenuItem "&PC"
.SetFocus
.Select
.SendVkey
Button Functions
.press
Check Box Functions
.Selected=True
List Box Functions
.Key="n"
ShellGrid Functions
.visiblerowcount
.getcellvalue(n, "COLUMN NAME")
.currentCellRow = n
.selectedRows = "" & n & ""
.doubleClickCurrentCell
.ClickCurrentCell
Text Box Functions
.text
Grab session already opened
Set SapApplication = SapGuiAuto.GetScriptingEngine
Set Connection = SapApplication.OpenConnection("Your Systems Name", True)
Set sessionN = Connection.Children(0)
'//NB Connection Can be set up as follows to avoid "Your Systems Name" differences on different pc's error as
Set Connection = SapApplication.OpenConnectionByConnectionString("/M/messageServerAddress/S/36**/G/group", True, True)
'// where ** is the option order number e.g 02 = 3602
Download Spool By Append Pages
Sub GetSapSpoolByAppendingPages()
'// # Assumptions #
'// # 1. Std Page View of 1-10 exists as initial default #
Dim n, mFrom, mTo
'// # Get SAP Obects WHERE SAP Logged in and at Menu Screen #
Set SapGuiAuto = GetObject("SAPGUI")
Set SAPplication = SapGuiAuto.GetScriptingEngine
Set Connection = SAPplication.Connections(0)
Set session = Connection.Children(0)
'// # Open Spool List #
session.findbyid("wnd[0]/tbar[0]/okcd").Text = "SP02"
session.findbyid("wnd[0]/tbar[0]/btn[0]").press
'// # Select Top Item In List #
session.findbyid("wnd[0]/usr/chk[1,3]").Selected = True
'// # Get Page Count #
pPages = session.findbyid("wnd[0]/usr/lbl[43,3]").Text
'// # Display Spool pages 1-10 (See Assumptions) #
session.findbyid("wnd[0]").SendvKey ("16")
'// # Get Pages In Chunks of 10 Pages #
For n = 1 To pPages Step 10
mFrom = n
mTo = n + 9
'// # If First time round select to ovwerwrite file [Append on Subsequent passes] #
If n = 1 Then
OW_or_Append = "OW"
Else
OW_or_Append = "Append"
End If
'// # Set Pages to Show #
session.findbyid("wnd[0]").SendvKey ("46")
session.findbyid("wnd[1]/usr/txtDIS_FROM").Text = mFrom
session.findbyid("wnd[1]/usr/txtDIS_TO").Text = mTo
session.findbyid("wnd[1]/tbar[0]/btn[0]").press
'// # Download Option Open #
session.findbyid("wnd[0]").SendvKey ("48")
'// # Select Default Format (Unconverted) and enter Save File Details #
session.findbyid("wnd[1]/tbar[0]/btn[0]").press
session.findbyid("wnd[1]/usr/ctxtDY_PATH").Text = "C:\temp"
session.findbyid("wnd[1]/usr/ctxtDY_FILENAME").Text = "PageTest.txt"
'// # Press Overwrite or Append Button #
If OW_or_Append = "Append" Then session.findbyid("wnd[1]/tbar[0]/btn[7]").press
If OW_or_Append = "OW" Then session.findbyid("wnd[1]/tbar[0]/btn[11]").press
Next
'// # Return to Main Menu #
session.findbyid("wnd[0]").SendvKey ("3")
session.findbyid("wnd[0]").SendvKey ("3")
'// # Release Memory Variables #
Set session = Nothing
Set Connection = Nothing
Set SAPplication = Nothing
Set SapGuiAuto = Nothing
End Sub
UI in VBA [nameOfYourChoice]
Required Reference
C:\windows\system32\UIAutomationCore.dll
Create Automation Object
Dim [UIObj] as New CUIAutomation
Get Root Element
Dim [Dsktp] As IUIAutomationElement : Set [Dsktp] = [UIObj].GetRootElement
Get All Children In Array
Dim [DtChildNodes] As IUIAutomationElementArray : Set [DtChildNodes] = [Dsktp].FindAll(TreeScope_Children, Auto.CreateTrueCondition)
Get a Value Procedure (Text and Number) and Use
Dim [VAL] As IUIAutomationValuePattern : Set [VAL] = [DialogNodes].GetElement([n]).GetCurrentPattern(UIA_PatternIds.UIA_ValuePatternId) :[VAL].SetValue [MyFilename]
Get an Invoke Procedure and Use
Dim [INV] As IUIAutomationInvokePattern : Set [INV] = [obSubMenuList].GetElement([n]).GetCurrentPattern(UIA_PatternIds.UIA_InvokePatternId) : [INV].Invoke
Get an Expand/Collapse Procedure and Use
Dim [EXP] As IUIAutomationExpandCollapsePattern : Set [EXP] = [obMenuList].GetElement([n]).GetCurrentPattern(UIA_PatternIds.UIA_ExpandCollapsePatternId):[EXP].Expand
Customised FindAll (e.g UIA_LocalizedControlTypePropertyId = "menu item")
Dim [SubMenuList] As IUIAutomationElementArray
Set [SubMenuList] = [DtChildNodes].GetElement([n]).FindAll(TreeScope_Subtree, Auto.CreatePropertyCondition(UIA_PropertyIds.UIA_LocalizedControlTypePropertyId, "menu item"))
SQL
VBA-SqlServer Connection
Sub SQLServerConn()
Dim conn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim sConnString As String
' Create the connection string.
sConnString = "Provider=SQLOLEDB;Data Source=< S E R V E R >\< S Q L E X P R E S S >;" & _
"Initial Catalog=< D B N A M E >;" & _
"Integrated Security=SSPI;"
' Create the Connection and Recordset objects.
Set conn = New ADODB.Connection
Set rs = New ADODB.Recordset
' Open the connection and execute.
conn.Open sConnString
Set rs = conn.Execute("SELECT * FROM < T A B L E >;")
Do While Not rs.EOF
Debug.Print rs(0)
rs.MoveNext
Loop
Set rs = Nothing
Set conn = Nothing
End Sub
Include Method
Read Script from a file into var e.g. fileText
ExecuteGlobal fileText
Usefull for debug in vbsEdit open all files and debug will pass to file called in this manner.
DSN Less Access SQL Connection
From MS Website - tested ok.
'//Name : AttachDSNLessTable
'//Purpose : Create a linked table to SQL Server without using a DSN
'//Parameters
'// stLocalTableName: Name of the table that you are creating in the current database
'// stRemoteTableName: Name of the table that you are linking to on the SQL Server database
'// stServer: Name of the SQL Server that you are linking to
'// stDatabase: Name of the SQL Server database that you are linking to
'// stUsername: Name of the SQL Server user who can connect to SQL Server, leave blank to use a Trusted Connection
'// stPassword: SQL Server user password
Function AttachDSNLessTable(stLocalTableName As String, stRemoteTableName As String, stServer As String, stDatabase As String, Optional stUsername As String, Optional stPassword As String)
On Error GoTo AttachDSNLessTable_Err
Dim td As TableDef
Dim stConnect As String
For Each td In CurrentDb.TableDefs
If td.Name = stLocalTableName Then
CurrentDb.TableDefs.Delete stLocalTableName
End If
Next
If Len(stUsername) = 0 Then
'//Use trusted authentication if stUsername is not supplied.
stConnect = "ODBC;DRIVER=SQL Server;SERVER=" & stServer & ";DATABASE=" & stDatabase & ";Trusted_Connection=Yes"
Else
'//WARNING: This will save the username and the password with the linked table information.
stConnect = "ODBC;DRIVER=SQL Server;SERVER=" & stServer & ";DATABASE=" & stDatabase & ";UID=" & stUsername & ";PWD=" & stPassword
End If
Set td = CurrentDb.CreateTableDef(stLocalTableName, dbAttachSavePWD, stRemoteTableName, stConnect)
CurrentDb.TableDefs.Append td
AttachDSNLessTable = True
Exit Function
AttachDSNLessTable_Err:
AttachDSNLessTable = False
MsgBox "AttachDSNLessTable encountered an unexpected error: " & Err.Description
End Function
Excel csv
At the top of the file write
sep=,
Excel Git
Sub git(msg)
' * Save new spreadsheet in a DevFolder with Subfolder GIT
' * Save this in your spreadsheet in a Module called git
' * Make sure your DevFolder has had git -init run on it at the command line
' * Work On your Module
' * When you want to commit
' * Be in the module you want to commit
' * type git.git "<some message>" in the immediate pane
CurrentPage = ThisWorkbook.VBProject.VBComponents.VBE.ActiveCodePane.CodeModule.Lines(1,ThisWorkbook.VBProject.VBComponents.VBE.ActiveCodePane.CodeModule.CountOfLines)
CurrentModule = ThisWorkbook.VBProject.VBComponents.VBE.ActiveCodePane.CodeModule.Parent.Name
currentFile = ThisWorkbook.Name
gitName = currentFile & "_" & CurrentModule & ".txt"
If Dir(gitName) <> "" Then
FileSystem.Kill gitName
End If
Set fso = CreateObject("Scripting.FileSystemObject")
Set OutFolder = fso.getfolder(ThisWorkbook.Path & "\GIT")
OutFolder.CreateTextFile (gitName)
Set fsoOut = fso.openTextFile("GIT\" & gitName, 8)
fsoOut.write CurrentPage
fsoOut.Close
Set fsoOut = Nothing
Set OutFile = Nothing
Set OutFolder = Nothing
Set fso = Nothing
Set sh = CreateObject("WScript.Shell")
sh.CurrentDirectory = ThisWorkbook.Path
Set shRtn = sh.exec("git commit -a -m """ & msg & """")
Select Case shRtn.Status
Case WshFinished
strOutput = shRtn.StdOut.ReadAll
Case WshFailed
strOutput = shRtn.StdErr.ReadAll
End Select
Debug.Print strOutput
Set sh = Nothing
End Sub