VBA Snippets

ADODB.Connection-toExcel.vb

Const adOpenStatic = 3
Const adLockOptimistic = 3
Const adCmdText = &H1

Set XConn = New ADODB.Connection
Set XRecSet = New ADODB.Recordset

XConn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
    "Data Source=U:\User Admin Tools\User Tables.xlsm;" & _
        "Extended Properties=""Excel 8.0;HDR=Yes;"";"
XRecSet.Open "SELECT * FROM [Active_Directory$]", _
XConn, adOpenStatic, adLockOptimistic, adCndText

'''''''''''''''''''''
''''Do Stuff Here''''
'''''''''''''''''''''

XRecSet.Close
XConn.Close
Set XRecSet = Nothing
Set XConn = Nothing

ADODB.Connection.vb

Dim cn As ADODB.Connection

Set cn = New ADODB.Connection
cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
        "Data Source=" + Environ("TEMP") + "\HSSC User Admin.accdb"

'''''''''''''''''''''
''''Do Stuff Here''''
'''''''''''''''''''''

cn.Close
Set cn = Nothing

ADODB.Recordset.vb

Set rs = New ADODB.Recordset
rs.Open "SELECT * FROM All_Hotels", cn

Do Until rs.EOF

  '''''''''''''''''''''
  ''''Do Stuff Here''''
  '''''''''''''''''''''

  rs.MoveNext
Loop

'or
Set rs = cn.Execute("SELECT * FROM All_Users WHERE Full_Name='" + uName + "';")

rs.Close
Set rs = Nothing

buildArray-NoDuplicates.vb

s = 1
For Each ghtl In sRange
    If ghtl.Value = "" Then
        Exit For
    End If
    Set currSpirit = New cHotel
    currSpirit.HotelID = ghtl.Value
    If currSpirit.Hotelgrid = currUser.ActionGrid Then
        If InStr(currUser.opAccess, currSpirit.HotelID) < 1 Then 'Check if User already has access to currSpirit
            If g = 1 Then   'Check if Master Array is empty
                ReDim Preserve arraySpirits(1 To i)
                Set arraySpirits(i) = currSpirit
                g = g + 1
            Else
                For Each sprt In arraySpirits   'Being sure not to add dulplicate Hotels
                    If sprt.HotelID = currSpirit.HotelID Or currSpirit.HotelID = "" Then 'Check if Spirit Already Exists in Array
                        inList = True
                    End If
                Next sprt
                If inList = False Then
                    currSpiritsCount = UBound(arraySpirits) + 1
                    ReDim Preserve arraySpirits(1 To currSpiritsCount)
                    Set arraySpirits(currSpiritsCount) = currSpirit
                End If
                inList = False
            End If
        End If
    End If
    s = s + 1
    Set currSpirit = Nothing
Next ghtl
Set sRange = Nothing

buildUserArrayFromWorksheet.vb

    'Build User Array
    For Each gId In uRange
        currUserCount = userRow - 1
        If gId.Value = "" Then
            Exit For
        End If
        Set currUser = New cUser
        With currUser
            .GlobalID = ActiveWorkbook.Worksheets("Main").Cells(userRow, 2).Value
            .action = ActiveWorkbook.Worksheets("Main").Cells(userRow, 3).Value
            .ActionGrid = ActiveWorkbook.Worksheets("Main").Cells(userRow, 4).Value
            .tickNum = ActiveWorkbook.Worksheets("Main").Cells(userRow, 1).Value
        End With
        ReDim Preserve arrayUsers(1 To currUserCount)
        Set arrayUsers(currUserCount) = currUser
        Set currUser = Nothing
        userRow = userRow + 1
    Next gId

checkStringForText.vb

Dim tGroups() As String, i As Long, j As Long, _
uName As String, cGrp As String
'Split String into an Array
tGroups = Split(currUser.TargetGroups, ",")
'Loop through Array
For Each grp In tGroups
    If Not InStr(currUser.GroupList, tGroups(i)) > 0 Then 'If the target group is in the user's group list
        uName = currUser.FullName
        cGrp = tGroups(i)
        tme = CStr(Now())
        Debug.Print ("<" + CStr(Now()) + ">" + uName + " is missing group " + cGrp + " in " + hotel.HotelID)
        j = j + 1
    End If
    i = i + 1
Next grp
Erase tGroups

checkUser.vb

Function checkUser(uGrps, tGrps) As Boolean
Dim tGroups() As String, groupMatch As Boolean, i As Long, j As Long, _
cGrp As String, x

j = 0
i = 0

tGroups = Split(tGrps, ",")
For Each grp In tGroups
    If Not InStr(uGrps, tGroups(i)) > 0 Then 'If the target group is in the user's group list
        j = j + 1
    End If
    i = i + 1
Next grp

Erase tGroups


If j > 0 Then 'If one of the groups is missing
    checkUser = False
Else
    checkUser = True
End If
End Function

Compe.vb

Public Function Compare(FolderPath As String, LookFor As String) As String
'Reference: Microsoft Scripting Runtime
    Dim pFSO As New FileSystemObject
    Dim pFld As Files
    Dim pObj As File
    Dim pObjText As Object
    Dim ts As String
'Connect to FolderPath provided
    Set pFld = pFSO.GetFolder(FolderPath).Files
'Cycle through each file in folder (This will not look at subfolders)
    For Each pObj In pFld
        'Store File as String
        Set pObjText = pObj.OpenAsTextStream(ForReading, TristateUseDefault)
        ts = pObjText.ReadAll
        pObjText.Close
        'Compare LookFor to String
            'Debug.Print InStr(1, ts, LookFor) > 0, pObj.name
            If InStr(1, ts, LookFor) > 0 Then Compare = Left(pObj.name, 5) & " | " & Compare
    Next pObj
End Function

createForm-Access.vb

Sub newGridForm(grid As String) 'Create new form

Dim nForm As Form, nTBox As TextBox, nTBLabel As Label, nButton As CommandButton, currRs As Recordset, _
SQLstr As String, frmName As String, currSpirit As String, lblName As String, x As Long, y As Long, gCount As Long, _
varString As String, cCount As Long

On Error Resume Next

frmName = grid & " Password Entry Form"
SQLstr = "SELECT * FROM All_Active_Hotels WHERE Grid='" & grid & "'"

Set currRs = CurrentDb.OpenRecordset(SQLstr) 'Get all hotels assigned to this grid

'Determine how many fields should be in each column
cCount = dCount("Spirit", "All_Active_Hotels", "Grid='" & grid & "'")
cCount = cCount / 3

Set nForm = CreateForm(, frmName)
nForm.Caption = frmName
nForm.AutoResize = True

'Fields position variables
x = 2000
y = 1000
gCount = 1

'Start adding fields
Do Until currRs.EOF
    currSpirit = currRs.Fields.Item("Spirit").Value
    Set nTBox = CreateControl(nForm.Name, acTextBox)
    nTBox.Name = currSpirit
    nTBox.InputMask = "Password"
    nTBox.Left = x
    nTBox.Top = y
    lblName = currSpirit & "lbl"
    Set nTBLabel = CreateControl(nForm.Name, acLabel)
    nTBLabel.Name = lblName
    nTBLabel.Caption = currSpirit
    nTBLabel.Left = x - 1000
    nTBLabel.Top = y
    nTBLabel.SizeToFit
    'Determine position for the current field
    If gCount = cCount Or gCount = cCount * 2 Or gCount = cCount * 3 Then
        y = 1000
    Else
        y = y + 500
    End If
    If gCount > cCount * 3 - 1 Then
        x = 11000
    ElseIf gCount < cCount * 3 And gCount > cCount * 2 - 1 Then
        x = 8000
    ElseIf gCount < cCount * 2 And gCount > cCount - 1 Then
        x = 5000
    ElseIf gCount < cCount Then
        x = 2000
    End If
    Set nTBox = Nothing
    Set nTBLabel = Nothing
    gCount = gCount + 1
    currRs.MoveNext
Loop

'Add buttons
Set nButton = CreateControl(nForm.Name, acCommandButton)

With nButton
    .Name = "submitPasses"
    .Caption = "Add Passwords To Database"
    .SizeToFit
    .Left = 1000
    .Top = 250
End With

Set nButton = Nothing
Set nButton = CreateControl(nForm.Name, acCommandButton)

With nButton
    .Name = "exitForm"
    .Caption = "Do Not Add These Passwords"
    .SizeToFit
    .Left = 4350
    .Top = 250
End With

Set nButton = Nothing
Set nButton = CreateControl(nForm.Name, acCommandButton)

With nButton
    .Name = "autoFillPass"
    .Caption = "Copy First To All"
    .SizeToFit
    .Left = 7750
    .Top = 250
End With

Set nButton = Nothing

'Add VBA to the form's module
Dim lRet As Long

lRet = nForm.Module.CreateEventProc("Load", "Form")
nForm.Module.InsertLines lRet + 1, "DoCmd.Close acForm, " & Chr(34) & "OperaLogin" & Chr(34) & ", acSaveNo"

lRet = nForm.Module.CreateEventProc("Click", "submitPasses")
nForm.Module.InsertLines lRet + 1, "Call udatPass(Me)"

lRet = nForm.Module.CreateEventProc("Click", "exitForm")
nForm.Module.InsertLines lRet + 1, "Call clsfrm(Me)"

lRet = nForm.Module.CreateEventProc("Click", "autoFillPass")
nForm.Module.InsertLines lRet + 1, "Call copyAllPass(Me)"
nForm.Module.InsertLines lRet + 2, "Me.submitPasses.SetFocus"

Application.VBE.MainWindow.Visible = False 'Keep VBA module from displaying

DoCmd.OpenForm (nForm.Name) 'Open form

nForm.SetFocus

Application.VBE.MainWindow.Visible = False 'Keep VBA module from displaying again

varString = SysCmd(acSysCmdSetStatus, "Please enter your password for each hotel or click 'Do Not Add These Passwords' to skip this grid.")

Set nForm = Nothing

End Sub

downloadFile.vb

Sub DownloadFile(sysID As String, rName As String, tDate As String)

Dim myURL As String, fName As String, fPath As String, x
myURL = (SOMEURL)

tDate = Replace(tDate, "-", "")
x = Split(rName, ".")
fName = x(0) + " " + tDate + "." + x(1)
Erase x

fPath = "C:\New Folder\"

Debug.Print (fName)
Dim WinHttpReq As Object
Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
WinHttpReq.Open "GET", myURL, False, "username", "password"
WinHttpReq.send

myURL = WinHttpReq.responseBody
If WinHttpReq.Status = 200 Then
    Set oStream = CreateObject("ADODB.Stream")
    oStream.Open
    oStream.Type = 1
    oStream.Write WinHttpReq.responseBody
    oStream.SaveToFile fPath + fName, 2 ' 1 = no overwrite, 2 = overwrite
    oStream.Close
End If

End Sub

encryptStringFunctions.vb

Function CryptRC4(sText As String, sKey As String) As String
Dim baS(0 To 255) As Byte, baK(0 To 255) As Byte, bytSwap As Byte, lI As Long, lJ As Long, lIdx As Long

For lIdx = 0 To 255
    baS(lIdx) = lIdx
    baK(lIdx) = Asc(mid$(sKey, 1 + (lIdx Mod Len(sKey)), 1))
Next

For lI = 0 To 255
    lJ = (lJ + baS(lI) + baK(lI)) Mod 256
    bytSwap = baS(lI)
    baS(lI) = baS(lJ)
    baS(lJ) = bytSwap
Next

lI = 0
lJ = 0

For lIdx = 1 To Len(sText)
    lI = (lI + 1) Mod 256
    lJ = (lJ + baS(lI)) Mod 256
    bytSwap = baS(lI)
    baS(lI) = baS(lJ)
    baS(lJ) = bytSwap
    CryptRC4 = CryptRC4 & Chr$((pvCryptXor(baS((CLng(baS(lI)) + baS(lJ)) Mod 256), Asc(mid$(sText, lIdx, 1)))))
Next

End Function
Function pvCryptXor(ByVal lI As Long, ByVal lJ As Long) As Long
If lI = lJ Then
    pvCryptXor = lJ
Else
    pvCryptXor = lI Xor lJ
End If
End Function
Public Function ToHexDump(sText As String) As String
Dim lIdx As Long

For lIdx = 1 To Len(sText)
    ToHexDump = ToHexDump & Right$("0" & Hex(Asc(mid(sText, lIdx, 1))), 2)
Next

End Function
Public Function FromHexDump(sText As String) As String
Dim lIdx As Long

For lIdx = 1 To Len(sText) Step 2
    FromHexDump = FromHexDump & Chr$(CLng("&H" & mid(sText, lIdx, 2)))
Next
End Function

GETxmlHTTP-andParseJSONresult.vb

Dim desc As String, result As String, _
uName As String, xml As MSXML2.XMLHTTP, x, y

Set xml = New MSXML2.XMLHTTP60
With xml
    .Open "GET", (SOMEURL) + tNum, False, (USERNAME), (PASSWORD)
    .send
End With
result = xml.responseText
result = Replace(result, Chr(34), "")
x = Split(result, ",")
For i = 0 To UBound(x)
    y = Split(x(i), ":")
    Select Case y(0)
        Case "short_description"
            If UBound(y) > 1 Then
                desc = y(1) + ": " + y(2)
            End If
        Case "caller_id"
            uName = y(1) 'User Sys ID
        Case "parent"
            parentSysID = y(1)
        Case "category"
            action = y(1)
        Case Else
    End Select
    Erase y
Next i
Erase x
xml.abort
Set xml = Nothing

IE_Sledgehammer.vb

Sub IE_Sledgehammer()
    Dim objWMI As Object, objProcess As Object, objProcesses As Object
    On Error Resume Next
    Set objWMI = GetObject("winmgmts://.")
    Set objProcesses = objWMI.ExecQuery( _
        "SELECT * FROM Win32_Process WHERE Name = 'iexplore.exe'")
    For Each objProcess In objProcesses
        Call objProcess.terminate
    Next
    Set objProcesses = Nothing: Set objWMI = Nothing
End Sub

ieArray-addFimGroups.vb

Sub addAllFimGroups(currUser As cUser)
Dim ie() As InternetExplorerMedium, groupArr() As String, GroupList As Range, i As Long, j As Long, uID As Integer

On Error Resume Next

'Get list of fim groups for user
Select Case currUser.opPosition
    Case "Customer_Service"
        Set GroupList = ActiveWorkbook.Worksheets("Groups").Range("E55:H55")
    Case "WMS"
        Set GroupList = ActiveWorkbook.Worksheets("Groups").Range("E56:H56")
    Case "AR_Agent"
        Set GroupList = ActiveWorkbook.Worksheets("Groups").Range("E57:H57")
    Case "AR_Manager"
        Set GroupList = ActiveWorkbook.Worksheets("Groups").Range("E57:H57")
    Case "AR_Cashier"
        Set GroupList = ActiveWorkbook.Worksheets("Groups").Range("E57:H57")
    Case "Payroll"
        Set GroupList = ActiveWorkbook.Worksheets("Groups").Range("E58:G58")
    Case Else
        Set GroupList = ActiveWorkbook.Worksheets("Groups").Range("E59:G59")
End Select

'Add group names to array
For i = 1 To GroupList.Count
    ReDim Preserve groupArr(0 To i - 1)
    groupArr(i - 1) = GroupList(i).Value
Next i
Set GroupList = Nothing
ReDim Preserve groupArr(0 To i - 1)
uID = CInt(currUser.GlobalID)


j = i - 1

ReDim Preserve ie(0 To j)

'Open new IE window for each group in array
For i = 0 To j
    Set ie(i) = New InternetExplorerMedium
    ie(i).Navigate currUser.fimURL  'Navigate each IE window to user's FIM profile
    ie(i).Visible = True
    apiShowWindow ie(i).HWnd, 1 'Resize IE window
Next i
Application.Wait (Now() + TimeValue("00:00:15"))

'Navigate to user's groups tab
For i = 0 To j
ie(i).document.getElementById("ctl00_PlaceHolderMain_EditPerson_uoc_navigate_GroupMembership_linkButton").Click
Next i
Application.Wait (Now() + TimeValue("00:00:15"))

'Add user to each group in array
For i = 0 To j
ie(i).document.getElementById("ctl00_PlaceHolderMain_EditPerson_uoc_GroupMembership_grouping_AddToGroup_control_internalObjectPicker_ctl00_txtPanel").innerText = groupArr(i)
ie(i).document.getElementById("ctl00_PlaceHolderMain_EditPerson_uoc_GroupMembership_grouping_AddToGroup_control_internalObjectPicker_ctl00_resolveImage").Click
Next i

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

'Click OK button in each IE window
For i = 0 To j
ie(i).document.getElementById("ctl00_PlaceHolderMain_EditPerson_uoc_buttonFinish").Click
Next i
Application.Wait (Now() + TimeValue("00:00:15"))

'Run script to submit each window
For i = 0 To j
    Call ie(i).document.parentWindow.execScript("ObjectControlSubmission.Start(); DisableSubmitCancelBack(this, 'ctl00_PlaceHolderMain_EditPerson_uoc_buttonCancel', 'ctl00_PlaceHolderMain_EditPerson_uoc_buttonBack', ''); __doPostBack('ctl00$PlaceHolderMain$EditPerson$uoc$buttonSubmit','')", "JScript")
Next i

Application.Wait (Now() + TimeValue("00:00:20"))
'Close all IE windows
Call IE_Sledgehammer
For i = 0 To j
    Set ie(i) = Nothing
Next i

Erase ie()
Erase groupArr()

End Sub

LibUser32.vb

Option Explicit
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Private Declare Function SetForegroundWindow Lib "user32" _
(ByVal lngHWnd As Long) As Long

Private Declare Function WaitForSingleObject Lib "user32" _
(ByVal lngHWnd As Long) As Long

Declare Function apiShowWindow Lib "user32" Alias "ShowWindow" _
            (ByVal HWnd As Long, ByVal nCmdShow As Long) As Long
            
Public Declare Function GetForegroundWindow Lib "user32" _
    () As Long
    
Public Declare Function GetWindowText Lib "user32" _
    Alias "GetWindowTextA" (ByVal HWnd As Long, _
    ByVal lpString As String, ByVal cch As Long) As Long
Function apicFindWindow(strClassName As String, strWindowName As String)
'Get window handle
Dim lngWnd As Long
apicFindWindow = FindWindow(strClassName, strWindowName)
End Function
Sub FocusPMS()
Dim hndl As Long
hndl = apicFindWindow("SunAwtFrame", vbNullString) 'Get PMS Window Handle
Call SetForegroundWindow(hndl) 'Set Focus on PMS Window
End Sub
Function getPMSTitle() As String
Dim WinText As String
Dim PMStitle As String
Dim HWnd As Long
Dim l As Long
HWnd = apicFindWindow("SunAwtFrame", vbNullString) 'Get PMS Window Handle GetForegroundWindow()
WinText = String(255, vbNullChar)
l = GetWindowText(HWnd, WinText, 255)
WinText = Left(WinText, InStr(1, WinText, vbNullChar) - 1)
WinText = Replace(WinText, "OPERA PMS [Version 5.0, Service Pack 5.0.03.03/37]                      ", "")
getPMSTitle = Trim(WinText)
End Function

openFileFromPath.vb

Sub openHotKey()
Dim x As Variant
Dim Path As String
Dim File As String
Path = "C:\Program Files (x86)\AutoHotkey\autohotkey.exe"
File = "C:\Users\2005671\Desktop\ShowTheD.ahk"
x = Shell(Path + " " + File, vbNormalFocus)
End Sub

outlook-NewMessage.vb

'''''''''''''''''''''''''''''''''
''''Put in ThisOutlookSession''''
'''''''''''''''''''''''''''''''''
Private Sub Items_ItemAdd(ByVal Item As Object)
Dim objNS As Outlook.NameSpace
Dim Msg As Outlook.MailItem
Dim olDestFldr As Outlook.MAPIFolder
Dim msgString As String
Set objNS = GetNamespace("MAPI")
Set olDestFldr = objNS.GetDefaultFolder(6).Folders("CompletedTickets")
If TypeOf Item Is Outlook.MailItem Then
    Set Msg = Item
    'mark as read and move to Completed Folder
    Msg.UnRead = False
    Msg.Move olDestFldr
    Set Msg = Nothing
End If
Set olDestFldr = Nothing
Set objNS = Nothing
End Sub

parseXML

Sub LoadUserValues(currUser As cUser, htl As cHotel)
Dim flPath As String, xml As String, uName As String

Dim oDoc As MSXML2.DOMDocument
Dim oNode As MSXML2.IXMLDOMNode
Dim oONode As MSXML2.IXMLDOMNode

On Error Resume Next
currUser.CurrentSpirit = ""
flPath = "O:\OperaUserSetUp\" + htl.HotelID + "_Users.xml"

'Import Text from file to string
Open flPath For Input As #1
xml = Input$(LOF(1), 1)
Close #1

'Clean up xml string for parsing
xml = Replace(xml, vbCrLf, "")
xml = Replace(xml, vbNewLine, "")
xml = Replace(xml, vbLf, "")
xml = Replace(xml, "                                                                                                                                                                                                                                                   ' AND Permission='Employee Configuration                                                                                                                                                                                                                                         ", "")

Set oDoc = New MSXML2.DOMDocument
oDoc.LoadXML (xml)

For Each oNode In oDoc.SelectNodes("/DATA/LIST_G_USER/G_USER")                  'Loop through each user in the XML file
    uName = Trim(oNode.SelectSingleNode("FULL_NAME").Text)
    If uName = currUser.FullName Then
        With currUser
            .CurrentSpirit = htl.HotelID
            .cashID = Trim(oNode.SelectSingleNode("CASHIER_ID").Text)
            .PMSAccess = Trim(oNode.SelectSingleNode("ACCESS_PMS").Text)
            .LastPass = Left(Trim(oNode.SelectSingleNode("PASSWORD_LAST_CHANGE").Text), 10)
            .GroupList = Trim(oNode.SelectSingleNode("USER_GROUPS").Text)
        End With
        Exit For
    End If
Next oNode
oDoc.abort
Set oDoc = Nothing

If Not currUser.CurrentSpirit = htl.HotelID Then
    'Set values to NoAccess because user was not found in report
    With currUser
        .CurrentSpirit = htl.HotelID
        .cashID = "NoAccess"
        .PMSAccess = "NoAccess"
        .LastPass = "NoAccess"
        .GroupList = "NoAccess"
    End With
End If
    
End Sub

parseXMLFile.vb

Dim oDoc As MSXML2.DOMDocument
Dim oNode As MSXML2.IXMLDOMNode

Open (FILEPATH) For Input As #1
xml = Input$(LOF(1), 1)
Close #1

Set oDoc = New MSXML2.DOMDocument
oDoc.loadXML (xml)

For Each oNode In oDoc.selectNodes("/DATA/LIST_G_USER/G_USER")                  'Loop through each user in the XML file
    uName = Trim(oNode.selectSingleNode("FULL_NAME").Text)
    cashID = Trim(oNode.selectSingleNode("CASHIER_ID").Text)
    x = Split(Trim(oNode.selectSingleNode("PASSWORD_LAST_CHANGE").Text), "T")
    lastPass = x(0)
    Erase x
    uGroups = Trim(oNode.selectSingleNode("USER_GROUPS").Text)
    
    uStr = cashID + "|" + uGroups + "|" + lastPass
    uName = Replace(uName, Chr(39), "(Chr(39))")
    
    SQLstr = "UPDATE [" + htl.AuditTable + "] SET " + _
    htl.HotelID & "='" & uStr & "' " & _
    "WHERE [Full_Name]='" & uName & "';"
    
    Debug.Print (SQLstr)
    CurrentDb.Execute (SQLstr)
            
    uName = ""
    cashID = ""
    lastPass = ""
    uGroups = ""
    uStr = ""
    SQLstr = ""

Next oNode

oDoc.abort
Set oDoc = Nothing

POSTxmlHTTP.vb

Dim xml As MSXML2.XMLHTTP, postText As String

url = "SOMEURL"
'Format postText as JSON
postText = "{" + Chr(34) + "assigned_to" + Chr(34) + ":" + Chr(34) + myName + Chr(34) + "," + _
            Chr(34) + "state" + Chr(34) + ":" + Chr(34) + "3" + Chr(34) + "}"
Set xml = New MSXML2.XMLHTTP60
With xml
    .Open "POST", url, False, (USERNAME), (PASSWORD)
    .send (postText)
End With
xml.abort
Set xml = Nothing

runAccessSub-Outlook.vb

Dim accessdb As Access.Application
Set accessdb = CreateObject("Access.Application")
accessdb.opencurrentdatabase "C:\CSDXA.mdb", False
accessdb.Application.Run ("ImportSNTickets")
accessdb.Application.Run ("DailyReporting"), 10
accessdb.Application.Run ("updateAgDash")
accessdb.CloseCurrentDatabase
Set accessdb = Nothing

scrapeFIMforUserGroups.vb

Set ie = New InternetExplorerMedium
ie.Navigate currUser.fimURL
ie.Visible = True
apiShowWindow ie.HWnd, 1

Application.Wait (Now() + TimeValue("00:00:10"))
While ie.Busy: DoEvents: Wend

Set doc = ie.document
doc.getElementById("ctl00_PlaceHolderMain_EditPerson_uoc_navigate_GroupMembership_linkButton").Click

Application.Wait (Now() + TimeValue("00:00:10"))
While ie.Busy: DoEvents: Wend

docTxt = doc.getElementById("ctl00_PlaceHolderMain_EditPerson_uoc_GroupMembership_grouping_HyattGroupMemberOf_control_internalListControl_internalListView_list").innerHTML

docTxt = Replace(docTxt, "</TBODY>", "")
docTxt = Replace(docTxt, "<TFOOT></TFOOT>", "")
docTxt = Replace(docTxt, Chr(39), "@")
docTxt = Replace(docTxt, Chr(34), "%")
docTxt = Replace(docTxt, vbCrLf, "")
docTxt = Replace(docTxt, "displayName=%", ":::")
docTxt = Replace(docTxt, "% objectId=%", ":::")

x = Split(docTxt, "objectType=%Group%")

For i = 0 To UBound(x)
    y = Split(x(i), ":::")
    currUser.GroupList = currUser.GroupList & y(1) & ";"
    Erase y
    Set y = Nothing
Next i

Erase x
Set x = Nothing

sendOutlookMessage.vb

Dim subj As String, mBody As String, _
msg As Outlook.MailItem

mBody =  "<html><body>" & _
                "Good morning," & "<br><br>" & _
                "According to our records,  the following request item is pending your approval.  " & _
                "Work on this task cannot begin until it has been reviewed and approved by you." & "<br><br>" & _
                "<a href=" & apURL & ">" & rs.Fields("Number").Value & "</a>" & "<br><br>" & _
                varTble & "<br><br>" & _
                "Please <a href=" & apURL & ">Click Here</a> to Approve or Reject this Requested Item.<br><br>" & _
                "Thank You," & "<br><br>" & _
                "HSSC Service Desk" & _
                "</body></html>"

'Send Messsage
Set msg = Application.CreateItem(olMailItem)
With msg
    .To = approver
    .SentOnBehalfOfName = "moore.servicedesk@hyatt.com"
    .Subject = subj
    .HTMLBody = mBody
    .Send
End With
Set msg = Nothing

TargGroups.vb

Function TargGroups(uPos As String, sCode As String, cn As ADODB.Connection) As String
Dim grps As String, hGrid As String, rec As ADODB.Recordset

Set rec = cn.Execute("SELECT * FROM [All_Hotels] WHERE Spirit='" + sCode + "';")
hGrid = rec.Fields("Grid")

'Set user target groups based on user position and grid name
Select Case uPos
    Case "AR_Agent"
        If hGrid = "Select" Or hGrid = "SelectSA" Then
            grps = rec.Fields("HSSC_Group") + "," + rec.Fields("Back_Office_Group") + "," + rec.Fields("Revenue_Group")
        Else
            grps = rec.Fields("HSSC_Group") + "," + rec.Fields("Back_Office_Group")
        End If
    Case "AR_Manager"
        If hGrid = "Select" Or hGrid = "SelectSA" Then
            grps = rec.Fields("HSSC_Group") + "," + rec.Fields("Back_Office_Group") + "," + rec.Fields("Revenue_Group")
        Else
            grps = rec.Fields("HSSC_Group") + "," + rec.Fields("Back_Office_Group")
        End If
    Case "AR_Cashier"
        If hGrid = "Select" Or hGrid = "SelectSA" Then
            grps = rec.Fields("HSSC_Group") + "," + rec.Fields("Back_Office_Group") + "," + rec.Fields("Revenue_Group") + "," + rec.Fields("Cashier_Group")
        Else
            grps = rec.Fields("HSSC_Group") + "," + rec.Fields("Back_Office_Group") + "," + rec.Fields("Cashier_Group")
        End If
    Case "Customer_Service"
        If hGrid = "Select" Or hGrid = "SelectSA" Then
            grps = rec.Fields("Cashier_Group") + "," + rec.Fields("Back_Office_Group")
        Else
            grps = rec.Fields("Cashier_Group") + "," + rec.Fields("Back_Office_Group")
        End If
    Case "Income_Journal"
        If hGrid = "Select" Or hGrid = "SelectSA" Then
            grps = rec.Fields("HSSC_Group") + "," + rec.Fields("Back_Office_Group") + "," + rec.Fields("Revenue_Group")
        Else
            grps = rec.Fields("HSSC_Group")
        End If
    Case "Tax_Agent"
        If hGrid = "Select" Or hGrid = "SelectSA" Then
            grps = rec.Fields("HSSC_Group") + "," + rec.Fields("Back_Office_Group") + "," + rec.Fields("Revenue_Group")
        Else
            grps = rec.Fields("HSSC_Group")
        End If
    Case Else
        grps = ""
End Select

rec.Close
Set rec = Nothing
grps = Replace(grps, ",No_Group", "")
grps = Replace(grps, "No_Group", "")
TargGroups = grps
End Function