Last active
April 26, 2018 17:18
-
-
Save afaulkinberry/641034dcb29e86e8ab28 to your computer and use it in GitHub Desktop.
VBA Snippets
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
'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 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
''''''''''''''''''''''''''''''''' | |
''''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 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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 |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment