bradyboyy88
Well-known Member
- Joined
- Feb 25, 2015
- Messages
- 562
So I have a macro enabled workbook that when i open it it always says file not found and highlights workbook_open. But if i go to my one module and delete all the info in there and tab out a few areas of my code in the workbook_open then it will work. Then when I re add back that stuff and untab the stuff it works. Makes no sense to me lol. Here is the module and the thisworksheet module. I cannot for the life of me figure this out but I think it might have to do with one of the api's not being able to find the correct dll? Since it highlights the workbook_open and never triggers the error handler I cant figure out which file is not found.
Rich (BB code):
Option Explicit
Public Sub Workbook_Open()
On Error GoTo ErrorHandler
'Speed up vba code
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'Icon Update
'Call SetIcon(ThisWorkbook.Path & "\Images\LOGO.ico", 0) ' THis is one i tab out to fix error since routine is in module that i delete to fix error
'Seperate Instance Declaration
Set ExcelGUIUpdates.App = Application
'Delete itself from history
Call ExcelGUIUpdates.DeleteRecentlyOpened
Set fso = CreateObject("Scripting.FileSystemObject")
'Create Regex Object string testing
Set RegEx = CreateObject("VBScript.RegExp")
'Application.DisplayAlerts = True
With Userform1
.StartUpPosition = 0
.Left = (0.5 * GetSystemMetrics(SM_CXSCREEN)) * 0.75 - (0.5 * .Width)
.Top = (0.5 * GetSystemMetrics(SM_CYSCREEN)) * 0.75 - (0.5 * .Height) - 10
.Show vbModeless
End With
'File not found error - NO clue but Resave. Then Open again then save as next version. Then save that. Then reopen and resave as something else and that one should work
Exit Sub
ErrorHandler:
Debug.Print "Error Number: " & Err.Number & ", Error Message: " & Err.Description & ", Last DLL Error: " & Err.LastDllError
End Sub
Sub Test()
Application.Quit
End Sub
Rich (BB code):
Option Explicit
'--------------------------------Create Icons Variable Declarations (API Mainly)----------------------------------'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' modSetIcon
' This module contains code to change the icon of the Excel main
' window. The code is compatible with 64-bit Office.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
#If VBA7 And Win64 Then
'''''''''''''''''''''''''''''
' 64 bit Excel
'''''''''''''''''''''''''''''
Private Declare PtrSafe Function SendMessageA Lib "user32" _
(ByVal hWnd As LongPtr, _
ByVal wMsg As LongPtr, _
ByVal wParam As LongPtr, _
ByVal lParam As LongPtr) As LongPtr
Private Declare PtrSafe Function ExtractIconA Lib "shell32.dll" _
(ByVal hInst As LongPtr, _
ByVal lpszExeFileName As String, _
ByVal nIconIndex As LongPtr) As Long
Private Const ICON_SMALL = 0&
Private Const ICON_BIG = 1&
Private Const WM_SETICON = &H80
#Else
'''''''''''''''''''''''''''''
' 32 bit Excel
'''''''''''''''''''''''''''''
Private Declare Function SendMessageA Lib "user32" _
(ByVal hWnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Integer, _
ByVal lParam As Long) As Long
Private Declare Function ExtractIconA Lib "shell32.dll" _
(ByVal hInst As Long, _
ByVal lpszExeFileName As String, _
ByVal nIconIndex As Long) As Long
Private Const ICON_SMALL As Long = 0&
Private Const ICON_BIG As Long = 1&
Private Const WM_SETICON As Long = &H80
#End If
'-------------Lightbox userform windowframe removal Variable Declariations (API Mainly)----------------------------'
'All Windows API variables that must be declared via module and not class module
'Hide userform window frames. Used in class module HideTitleBar
Public Const GWL_STYLE = -16
Public Const WS_CAPTION = &HC00000
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" ( _
ByVal hWnd As Long, _
ByVal nIndex As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" ( _
ByVal hWnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Public Declare Function DrawMenuBar Lib "user32" ( _
ByVal hWnd As Long) As Long
Public Declare Function FindWindowA Lib "user32" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
'------------------------------Open file API Calls--------------------------------------------'
#If VBA7 And Win64 Then
Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" _
Alias "ShellExecuteA" (ByVal hWnd As Long, _
ByVal lpOperation As String, ByVal lpFile As String, _
ByVal lpParameters As String, ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long
#Else
Private Declare Function ShellExecute Lib "shell32.dll" _
Alias "ShellExecuteA" (ByVal hWnd As Long, _
ByVal lpOperation As String, ByVal lpFile As String, _
ByVal lpParameters As String, ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long
#End If
'--------------------------------Create Icons--------------------------------------------------'
Sub SetIcon(FileName As String, Optional index As Long = 0)
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' SetIcon
' This procedure sets the icon in the upper left corner of
' the main Excel window. FileName is the name of the file
' containing the icon. It may be an .ico file, an .exe file,
' or a .dll file. If it is an .ico file, Index must be 0
' or omitted. If it is an .exe or .dll file, Index is the
' 0-based index to the icon resource.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
#If VBA7 And Win64 Then
' 64 bit Excel
Dim hWnd As LongPtr
Dim HIcon As LongPtr
#Else
' 32 bit Excel
Dim hWnd As Long
Dim HIcon As Long
#End If
Dim n As Long
Dim S As String
If Dir(FileName, vbNormal) = vbNullString Then
' file not found, get out
Exit Sub
End If
' get the extension of the file.
n = InStrRev(FileName, ".")
S = LCase(Mid(FileName, n + 1))
' ensure we have a valid file type
Select Case S
Case "exe", "ico", "dll"
' OK
Case Else
' invalid file type
Err.Raise 5
End Select
hWnd = Application.hWnd
If hWnd = 0 Then
Exit Sub
End If
HIcon = ExtractIconA(0, FileName, index)
If HIcon <> 0 Then
SendMessageA hWnd, WM_SETICON, ICON_SMALL, HIcon
End If
End Sub
'------------------------Lightbox userform windowframe removal-----------------------------'
Sub HideTitleBar(frm As Object)
Dim lngWindow As Long
Dim lFrmHdl As Long
lFrmHdl = FindWindowA(vbNullString, frm.Caption)
lngWindow = GetWindowLong(lFrmHdl, GWL_STYLE)
lngWindow = lngWindow And (Not WS_CAPTION)
Call SetWindowLong(lFrmHdl, GWL_STYLE, lngWindow)
Call DrawMenuBar(lFrmHdl)
End Sub
'------------------------Allow user to return single file from filedialog-------------------------'
Function SingleFilePath()
Dim intChoice As Integer
Dim strPath As String
'only allow the user to select one file
Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False
'make the file dialog visible to the user
intChoice = Application.FileDialog(msoFileDialogOpen).Show
'determine what choice the user made
If intChoice <> 0 Then
'get the file path selected by the user
strPath = Application.FileDialog(msoFileDialogOpen).SelectedItems(1)
'return the filepath
SingleFilePath = strPath
End If
End Function
'---------------------Allow user to return multiple files from filedialog---------------------'
Function MultipleFilePath() As String()
Dim intChoice As Integer
Dim strPath() As String
Dim i As Integer
'allow the user to select multiple files
Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = True
'make the file dialog visible to the user
intChoice = Application.FileDialog(msoFileDialogOpen).Show
'determine what choice the user made
If intChoice <> 0 Then
'get the file path selected by the user
For i = 1 To Application.FileDialog(msoFileDialogOpen).SelectedItems.count
strPath = Application.FileDialog(msoFileDialogOpen).SelectedItems(i)
Next i
End If
MultipleFilePath = strPath
End Function
'Open files command
Sub OpenFile(StringPath As String)
If fso.GetExtensionName(StringPath) = "xls" Or fso.GetExtensionName(StringPath) = "xlsm" _
Or fso.GetExtensionName(StringPath) = "xlsx" Then
Dim xlApp As Application
Set xlApp = CreateObject("Excel.Application")
Application.DisplayAlerts = False
xlApp.Workbooks.Open StringPath, , True
Application.DisplayAlerts = True
xlApp.Visible = True
Set xlApp = Nothing
ElseIf fso.GetExtensionName(StringPath) = "doc" Or fso.GetExtensionName(StringPath) = "pdf" _
Or fso.GetExtensionName(StringPath) = "txt" Then
Dim Result As Long
Result = ShellExecute(0&, vbNullString, StringPath, _
vbNullString, vbNullString, vbNormalFocus)
If Result < 32 Then MsgBox "Error"
Else
Dim objShell As Object
Set objShell = CreateObject("Shell.Application")
Application.DisplayAlerts = False
objShell.Open (StringPath)
Application.DisplayAlerts = True
Set objShell = Nothing
End If
End Sub
'Copy files without waiting for file transfer to resume code
Sub FileCopyImproved(sSourceFile As String, sDestFile As String)
'Asynch File Copy
Shell Environ$("comspec") & " /c xcopy /y """ & sSourceFile & """ """ & sDestFile & "*" & """ ", vbHide
End Sub
Function CorrectMMCIDFormat(MMCIDEntered As String)
'Check Formatting of MMCID Entered
If Len(MMCIDEntered) = 11 Then
RegEx.Pattern = "[A-Za-z]"
If RegEx.Test(Left(MMCIDEntered, 2)) Then
RegEx.Pattern = "^[0-9]+$"
If RegEx.Test(Right(MMCIDEntered, 8)) Then
If Mid(MMCIDEntered, 3, 1) = "-" Then
CorrectMMCIDFormat = True
Else
CorrectMMCIDFormat = False
End If
Else
CorrectMMCIDFormat = False
End If
Else
CorrectMMCIDFormat = False
End If
Else
CorrectMMCIDFormat = False
End If
End Function
Function stripEnclosed(strIn As String) As String
'need to enable ms vbscript regular
Dim re As VBScript_RegExp_55.RegExp, AllMatches As VBScript_RegExp_55.MatchCollection, M As VBScript_RegExp_55.Match
Dim closeIndex As Long
Dim tmpstr As String
tmpstr = strIn
Set re = New VBScript_RegExp_55.RegExp
re.Global = True
re.Pattern = "<[^/>]+>"
Set AllMatches = re.Execute(tmpstr)
For Each M In AllMatches
closeIndex = InStr(tmpstr, Replace(M.value, "<", "</"))
If closeIndex <> 0 Then tmpstr = Left(tmpstr, InStr(tmpstr, M.value) - 1) & Mid(tmpstr, closeIndex + Len(M.value) + 1)
Next M
stripEnclosed = tmpstr
End Function
Public Function StripHTML(str As String) As String
Dim RegEx As Object
Set RegEx = CreateObject("vbscript.regexp")
With RegEx
.Global = True
.IgnoreCase = True
.MultiLine = True
.Pattern = "<[^>]+>"
End With
StripHTML = RegEx.Replace(str, "")
Set RegEx = Nothing
End Function
Sub ProcessStepTracking(MMCID As Integer, SenderRole As Integer, RecipientRole As Integer, DateString As String, connectionOpen As Boolean)
If connectionOpen Then
DatabaseMethods.SQLOpenDatabaseConnection DatabaseDirectory, 0
End If
Dim ProcessVersionTrackingVar As Integer
Dim CurrentStep As Integer
Dim LastStep As Integer
Dim CurrentVersion As Integer
Dim MaxVersionStep As Integer
Dim MaxOrdering As Integer
Dim IsIterative As Boolean
Dim CurrentOrder As Integer
Dim CurrentRound As Integer
SQLQueryCode = "SELECT PRT.PROCESS_VERSION, PRT.PROCESS_STEP,PRT.ROUND, PRT.DATE_ENTERED " & _
"FROM (PROCESS_AND_REVIEW_TRACKING PRT INNER JOIN BASEREVIEW BR " & _
"ON BR.PROCESS_ORDERING_SET_DD=PRT.PROCESS_VERSION AND PRT.MMCID=BR.MMCID) " & _
"WHERE PRT.MMCID= " & MMCID & " ORDER BY PRT.ROUND DESC,PRT.DATE_ENTERED DESC, PRT.PROCESS_STEP DESC"
Set ActiveRecordset = DatabaseMethods.SQLQueryDatabaseRecordset(SQLQueryCode)
LastProcessStep = ActiveRecordset.Fields("Process_Step").value
CurrentVersion = ActiveRecordset.Fields("PROCESS_VERSION").value
CurrentRound = ActiveRecordset.Fields("ROUND").value
SQLQueryCode = "SELECT PO.MAXSTEP, PVO.ORDERING, PV.ITERABLE " & _
"FROM ((SELECT MAX(PROCESS_ID_NUMBER) AS MAXSTEP, PROCESS_SET_VERSION FROM Process_Ordering WHERE PROCESS_SET_VERSION=" & CurrentVersion & " GROUP BY PROCESS_SET_VERSION) AS PO INNER JOIN PROCESS_VERSION_ORDERING AS PVO ON PO.PROCESS_SET_VERSION=PVO.PROCESS_VERSION_NUMBER) " & _
"INNER JOIN PROCESS_VERSIONS AS PV ON PO.PROCESS_SET_VERSION=PV.VERSION_NUMBER "
Set ActiveRecordset = DatabaseMethods.SQLQueryDatabaseRecordset(SQLQueryCode)
MaxVersionStep = ActiveRecordset.Fields("MAXSTEP").value
CurrentOrder = ActiveRecordset.Fields("ORDERING").value
IsIterative = ActiveRecordset.Fields("ITERABLE").value
If LastProcessStep = MaxVersionStep Then
If IsIterative Then
SQLQueryCode = "SELECT PO.PROCESS_ID_NUMBER,PO.PROCESS_STEP_DISPLAY_TEXT FROM Process_Ordering AS PO WHERE PO.PROCESS_ID_NUMBER>0 AND PO.PROCESS_SET_VERSION=" & CurrentVersion & " ORDER BY PO.PROCESS_ID_NUMBER ASC"
Set ActiveRecordset = DatabaseMethods.SQLQueryDatabaseRecordset(SQLQueryCode)
ProcessVersionTrackingVar = ActiveRecordset.Fields("PROCESS_ID_NUMBER").value
ProcessConfirmationMessage = ActiveRecordset.Fields("PROCESS_STEP_DISPLAY_TEXT").value
CurrentRound = CurrentRound + 1
Else
SQLQueryCode = "SELECT T3.NEXT_VERSION_NUMBER, T4.PROCESS_STEP_DISPLAY_TEXT FROM (SELECT T2.PROCESS_VERSION_NUMBER AS NEXT_VERSION_NUMBER FROM ( SELECT BaseReview.MMCID, Process_Version_Ordering.ORDERING+1 AS ORDERING_PLUS_ONE, Process_Version_Ordering.LARGER_PROCESS_VERSION_GROUP, Process_Version_Ordering.PROCESS_VERSION_NUMBER FROM Process_Version_Ordering INNER JOIN BaseReview ON " & _
"(Process_Version_Ordering.LARGER_PROCESS_VERSION_GROUP = BaseReview.LARGER_PROCESS_VERSION_GROUP) AND (Process_Version_Ordering.PROCESS_VERSION_NUMBER = BaseReview.PROCESS_ORDERING_SET_DD) WHERE BaseReview.MMCID = " & ActiveMMCID & " ) AS T1 " & _
" INNER Join Process_Version_Ordering As T2 ON T1.LARGER_PROCESS_VERSION_GROUP=T2.LARGER_PROCESS_VERSION_GROUP WHERE T1.ORDERING_PLUS_ONE = T2.ORDERING ) AS T3 INNER JOIN Process_Ordering AS T4 ON T3.NEXT_VERSION_NUMBER=T4.PROCESS_SET_VERSION WHERE PROCESS_ID_NUMBER=1"
Set ActiveRecordset = DatabaseMethods.SQLQueryDatabaseRecordset(SQLQueryCode)
If ActiveRecordset.RecordCount = 0 Then
ProcessVersionTrackingVar = Null
ProcessConfirmationMessage = ""
Else
'Append basereview table for new version number
SQLQueryCode = "UPDATE BASEREVIEW" & _
" SET PROCESS_ORDERING_SET_DD=" & ActiveRecordset.Fields("NEXT_VERSION_NUMBER").value & _
" WHERE MMCID=" & ActiveMMCID
Call DatabaseMethods.SQLWriteDatabase(SQLQueryCode)
'New version always has first step as 1
ProcessVersionTrackingVar = 1
CurrentRound = 1
CurrentVersion = ActiveRecordset.Fields("PROCESS_SET_VERSION").value
ProcessConfirmationMessage = ActiveRecordset.Fields("PROCESS_STEP_DISPLAY_TEXT").value
End If
End If
Else
ProcessVersionTrackingVar = LastProcessStep + 1
SQLQueryCode = "SELECT PO.PROCESS_ID_NUMBER,PO.PROCESS_STEP_DISPLAY_TEXT FROM Process_Ordering AS PO WHERE PO.PROCESS_ID_NUMBER=" & ProcessVersionTrackingVar & " AND PO.PROCESS_SET_VERSION=" & CurrentVersion
Set ActiveRecordset = DatabaseMethods.SQLQueryDatabaseRecordset(SQLQueryCode)
ProcessConfirmationMessage = ActiveRecordset.Fields("PROCESS_STEP_DISPLAY_TEXT").value
End If
'Update Table
If Not IsNull(ProcessVersionTrackingVar) Then
'Jerry rig for fake DMCP entries for steps 9, 10, 11
If (ProcessVersionTrackingVar = 9 Or ProcessVersionTrackingVar = 10 Or ProcessVersionTrackingVar = 11) And CurrentVersion = ProcessVersionQuestionSet Then
SQLQueryCode = "INSERT INTO Process_and_Review_Tracking (MMCID, ROUND, SENDER, SENDERS_ROLE, RECIPIENT_ROLE, PROCESS_VERSION, PROCESS_STEP, DATE_ENTERED)" & _
" VALUES (" & MMCID & "," & CurrentRound & "," & UserNumber & "," & SenderRole & "," & RecipientRole & "," & CurrentVersion & "," & ProcessVersionTrackingVar & ", FORMAT(#" & CDate(DateString) & "#,'MM/DD/YYYY HH:mm:ss'))"
Call DatabaseMethods.SQLWriteDatabase(SQLQueryCode)
ProcessVersionTrackingVar = ProcessVersionTrackingVar + 1
SQLQueryCode = "INSERT INTO Process_and_Review_Tracking (MMCID, ROUND, SENDER, SENDERS_ROLE, RECIPIENT_ROLE, PROCESS_VERSION, PROCESS_STEP, DATE_ENTERED)" & _
" VALUES (" & MMCID & "," & CurrentRound & "," & UserNumber & "," & SenderRole & "," & RecipientRole & "," & CurrentVersion & "," & ProcessVersionTrackingVar & ", FORMAT(#" & CDate(DateString) & "#,'MM/DD/YYYY HH:mm:ss'))"
Call DatabaseMethods.SQLWriteDatabase(SQLQueryCode)
ProcessVersionTrackingVar = ProcessVersionTrackingVar + 1
SQLQueryCode = "INSERT INTO Process_and_Review_Tracking (MMCID, ROUND, SENDER, SENDERS_ROLE, RECIPIENT_ROLE, PROCESS_VERSION, PROCESS_STEP, DATE_ENTERED)" & _
" VALUES (" & MMCID & "," & CurrentRound & "," & UserNumber & "," & SenderRole & "," & RecipientRole & "," & CurrentVersion & "," & ProcessVersionTrackingVar & ", FORMAT(#" & CDate(DateString) & "#,'MM/DD/YYYY HH:mm:ss'))"
Call DatabaseMethods.SQLWriteDatabase(SQLQueryCode)
Else
SQLQueryCode = "INSERT INTO Process_and_Review_Tracking (MMCID, ROUND, SENDER, SENDERS_ROLE, RECIPIENT_ROLE, PROCESS_VERSION, PROCESS_STEP, DATE_ENTERED)" & _
" VALUES (" & MMCID & "," & CurrentRound & "," & UserNumber & "," & SenderRole & "," & RecipientRole & "," & CurrentVersion & "," & ProcessVersionTrackingVar & ", FORMAT(#" & CDate(DateString) & "#,'MM/DD/YYYY HH:mm:ss'))"
Call DatabaseMethods.SQLWriteDatabase(SQLQueryCode)
End If
End If
If connectionOpen Then
DatabaseMethods.SQLCloseDatabaseConnection
End If
End Sub
Sub ProcessVersionTracking(MMCID As Integer, SenderRole As Integer, RecipientRole As Integer, DateString As String, connectionOpen As Boolean)
If connectionOpen Then
DatabaseMethods.SQLOpenDatabaseConnection DatabaseDirectory, 0
End If
Dim ProcessVersionTrackingVar As Integer
Dim CurrentVersion As Integer
Dim CurrentRound As Integer
SQLQueryCode = "SELECT T2.PROCESS_VERSION_NUMBER AS NEXT_VERSION_NUMBER FROM ( SELECT BaseReview.MMCID, Process_Version_Ordering.ORDERING+1 AS ORDERING_PLUS_ONE, Process_Version_Ordering.LARGER_PROCESS_VERSION_GROUP, " & _
" Process_Version_Ordering.PROCESS_VERSION_NUMBER FROM Process_Version_Ordering INNER JOIN BaseReview ON (Process_Version_Ordering.LARGER_PROCESS_VERSION_GROUP = BaseReview.LARGER_PROCESS_VERSION_GROUP) AND (Process_Version_Ordering.PROCESS_VERSION_NUMBER = BaseReview.PROCESS_ORDERING_SET_DD) " & _
" WHERE BaseReview.MMCID = " & MMCID & " ) AS T1 INNER Join Process_Version_Ordering As T2 ON T1.LARGER_PROCESS_VERSION_GROUP=T2.LARGER_PROCESS_VERSION_GROUP WHERE T1.ORDERING_PLUS_ONE = T2.ORDERING"
Set ActiveRecordset = DatabaseMethods.SQLQueryDatabaseRecordset(SQLQueryCode)
'Assume first step in process version is always 1
ProcessVersionTrackingVar = 1
CurrentRound = 1
'Update Table
If ActiveRecordset.RecordCount > 0 Then
SQLQueryCode = "INSERT INTO Process_and_Review_Tracking (MMCID, ROUND, SENDER, SENDERS_ROLE, RECIPIENT_ROLE, PROCESS_VERSION, PROCESS_STEP, DATE_ENTERED)" & _
" VALUES (" & MMCID & "," & CurrentRound & "," & UserNumber & "," & SenderRole & "," & RecipientRole & "," & ActiveRecordset.Fields("NEXT_VERSION_NUMBER").value & "," & ProcessVersionTrackingVar & ", FORMAT(#" & CDate(DateString) & "#,'MM/DD/YYYY HH:mm:ss'))"
Call DatabaseMethods.SQLWriteDatabase(SQLQueryCode)
SQLQueryCode = "UPDATE BASEREVIEW SET PROCESS_ORDERING_SET_DD = " & ActiveRecordset.Fields("NEXT_VERSION_NUMBER").value & " WHERE MMCID= " & MMCID
Call DatabaseMethods.SQLWriteDatabase(SQLQueryCode)
End If
If connectionOpen Then
DatabaseMethods.SQLCloseDatabaseConnection
End If
End Sub
Function NextStepButtonText(MMCID As Integer, SenderRole As Integer, RecipientRole As Integer, DateString As String, connectionOpen As Boolean) As String
If connectionOpen Then
DatabaseMethods.SQLOpenDatabaseConnection DatabaseDirectory, 0
End If
Dim ProcessVersionTrackingVar As Integer
Dim CurrentStep As Integer
Dim LastStep As Integer
Dim CurrentVersion As Integer
Dim MaxVersionStep As Integer
Dim MaxOrdering As Integer
Dim IsIterative As Boolean
Dim CurrentOrder As Integer
Dim CurrentRound As Integer
Dim ButtonText As String
SQLQueryCode = "SELECT PRT.PROCESS_VERSION, PRT.PROCESS_STEP,PRT.ROUND, PRT.DATE_ENTERED " & _
"FROM (PROCESS_AND_REVIEW_TRACKING PRT INNER JOIN BASEREVIEW BR " & _
"ON BR.PROCESS_ORDERING_SET_DD=PRT.PROCESS_VERSION AND PRT.MMCID=BR.MMCID) " & _
"WHERE PRT.MMCID= " & MMCID & " ORDER BY PRT.DATE_ENTERED DESC, PRT.ROUND DESC, PRT.PROCESS_STEP DESC"
Set ActiveRecordset = DatabaseMethods.SQLQueryDatabaseRecordset(SQLQueryCode)
LastProcessStep = ActiveRecordset.Fields("Process_Step").value
CurrentVersion = ActiveRecordset.Fields("PROCESS_VERSION").value
CurrentRound = ActiveRecordset.Fields("ROUND").value
SQLQueryCode = "SELECT PO.MAXSTEP, PVO.ORDERING, PV.ITERABLE " & _
"FROM ((SELECT MAX(PROCESS_ID_NUMBER) AS MAXSTEP, PROCESS_SET_VERSION FROM Process_Ordering WHERE PROCESS_SET_VERSION=" & CurrentVersion & " GROUP BY PROCESS_SET_VERSION) AS PO INNER JOIN PROCESS_VERSION_ORDERING AS PVO ON PO.PROCESS_SET_VERSION=PVO.PROCESS_VERSION_NUMBER) " & _
"INNER JOIN PROCESS_VERSIONS AS PV ON PO.PROCESS_SET_VERSION=PV.VERSION_NUMBER "
Set ActiveRecordset = DatabaseMethods.SQLQueryDatabaseRecordset(SQLQueryCode)
MaxVersionStep = ActiveRecordset.Fields("MAXSTEP").value
CurrentOrder = ActiveRecordset.Fields("ORDERING").value
IsIterative = ActiveRecordset.Fields("ITERABLE").value
If LastProcessStep = MaxVersionStep Then
If IsIterative Then
SQLQueryCode = "SELECT PO.PROCESS_ID_NUMBER,PO.PROCESS_STEP_DISPLAY_TEXT,PO.PROCESS_ACTION_BUTTON_TEXT FROM Process_Ordering AS PO WHERE PO.PROCESS_ID_NUMBER>0 AND PO.PROCESS_SET_VERSION=" & CurrentVersion & " ORDER BY PO.PROCESS_ID_NUMBER ASC"
Set ActiveRecordset = DatabaseMethods.SQLQueryDatabaseRecordset(SQLQueryCode)
ProcessVersionTrackingVar = ActiveRecordset.Fields("PROCESS_ID_NUMBER").value
ProcessConfirmationMessage = ActiveRecordset.Fields("PROCESS_STEP_DISPLAY_TEXT").value
CurrentRound = CurrentRound + 1
ButtonText = ActiveRecordset.Fields("PROCESS_ACTION_BUTTON_TEXT").value
Else
SQLQueryCode = "SELECT PROCESS_VERSION_NUMBER FROM PROCESS_VERSION_ORDERING WHERE ORDERING=" & CurrentOrder + 1
Set ActiveRecordset = DatabaseMethods.SQLQueryDatabaseRecordset(SQLQueryCode)
If IsNull(ActiveRecordset.Fields("PROCESS_VERSION_NUMBER").value) Then
ProcessVersionTrackingVar = Null
ProcessConfirmationMessage = ""
ButtonText = "Null"
Else
SQLQueryCode = "SELECT PROCESS_ID_NUMBER, PROCESS_SET_VERSION,PROCESS_STEP_DISPLAY_TEXT,PROCESS_ACTION_BUTTON_TEXT FROM PROCESS_ORDERING WHERE PROCESS_SET_VERSION=" & ActiveRecordset.Fields("PROCESS_VERSION_NUMBER").value & " AND PROCESS_ID_NUMBER>0 ORDER BY PROCESS_ID_NUMBER ASC"
Set ActiveRecordset = DatabaseMethods.SQLQueryDatabaseRecordset(SQLQueryCode)
ProcessVersionTrackingVar = ActiveRecordset.Fields("PROCESS_ID_NUMBER").value
CurrentVersion = ActiveRecordset.Fields("PROCESS_SET_VERSION").value
ProcessConfirmationMessage = ActiveRecordset.Fields("PROCESS_STEP_DISPLAY_TEXT").value
ButtonText = ActiveRecordset.Fields("PROCESS_ACTION_BUTTON_TEXT").value
End If
End If
Else
ProcessVersionTrackingVar = LastProcessStep + 1
SQLQueryCode = "SELECT PO.PROCESS_ID_NUMBER,PO.PROCESS_STEP_DISPLAY_TEXT,PO.PROCESS_ACTION_BUTTON_TEXT FROM Process_Ordering AS PO WHERE PO.PROCESS_ID_NUMBER=" & ProcessVersionTrackingVar & " AND PO.PROCESS_SET_VERSION=" & CurrentVersion
Set ActiveRecordset = DatabaseMethods.SQLQueryDatabaseRecordset(SQLQueryCode)
ProcessConfirmationMessage = ActiveRecordset.Fields("PROCESS_STEP_DISPLAY_TEXT").value
ButtonText = ActiveRecordset.Fields("PROCESS_ACTION_BUTTON_TEXT").value
End If
'Update Table
NextStepButtonText = ButtonText
If connectionOpen Then
DatabaseMethods.SQLCloseDatabaseConnection
End If
End Function
Function IsMaxProcessStep(MMCID As Integer, CheckIterative As Boolean, connectionOpen As Boolean)
Dim LastStep As Integer
Dim CurrentVersion As Integer
Dim MaxVersionStep As Integer
Dim CurrentOrder As Integer
Dim IsIterative As Boolean
If connectionOpen Then
DatabaseMethods.SQLOpenDatabaseConnection DatabaseDirectory, 0
End If
SQLQueryCode = "SELECT PRT.PROCESS_VERSION, PRT.PROCESS_STEP,PRT.ROUND, PRT.DATE_ENTERED " & _
"FROM (PROCESS_AND_REVIEW_TRACKING PRT INNER JOIN BASEREVIEW BR " & _
"ON BR.PROCESS_ORDERING_SET_DD=PRT.PROCESS_VERSION AND PRT.MMCID=BR.MMCID) " & _
"WHERE PRT.MMCID= " & MMCID & " ORDER BY PRT.DATE_ENTERED DESC, PRT.ROUND DESC, PRT.PROCESS_STEP DESC"
Set ActiveRecordset = DatabaseMethods.SQLQueryDatabaseRecordset(SQLQueryCode)
LastStep = ActiveRecordset.Fields("Process_Step").value
CurrentVersion = ActiveRecordset.Fields("PROCESS_VERSION").value
SQLQueryCode = "SELECT PO.MAXSTEP, PVO.ORDERING, PV.ITERABLE " & _
"FROM ((SELECT MAX(PROCESS_ID_NUMBER) AS MAXSTEP, PROCESS_SET_VERSION FROM Process_Ordering WHERE PROCESS_SET_VERSION=" & CurrentVersion & " GROUP BY PROCESS_SET_VERSION) AS PO INNER JOIN PROCESS_VERSION_ORDERING AS PVO ON PO.PROCESS_SET_VERSION=PVO.PROCESS_VERSION_NUMBER) " & _
"INNER JOIN PROCESS_VERSIONS AS PV ON PO.PROCESS_SET_VERSION=PV.VERSION_NUMBER "
Set ActiveRecordset = DatabaseMethods.SQLQueryDatabaseRecordset(SQLQueryCode)
MaxVersionStep = ActiveRecordset.Fields("MAXSTEP").value
CurrentOrder = ActiveRecordset.Fields("ORDERING").value
IsIterative = ActiveRecordset.Fields("ITERABLE").value
If CheckIterative = True Then
If LastStep = MaxVersionStep And IsIterative = True Then
IsMaxProcessStep = True
Else
IsMaxProcessStep = False
End If
Else
If LastStep = MaxVersionStep Then
IsMaxProcessStep = True
Else
IsMaxProcessStep = False
End If
End If
If connectionOpen Then
DatabaseMethods.SQLCloseDatabaseConnection
End If
End Function
'This is for the update of the validating documents. Since the dynamic button class cant access forms subroutines we have to put it here
Sub ActivateValidateDocs(DocumentToValidate As String)
DocumentValidated = DocumentToValidate
'Clear old Contents
MMCARMS.ValidateDocFrame.ValidateDocBorderFrame.TypeDropDownBoxDoc.Clear
'ACTIVATE THE SCREEN!
With MMCARMS.MMCIDMainBlurrImage
.Width = MMCARMS.Width
.Height = MMCARMS.Height
.Top = 0
.Left = 0
.Visible = True
.ZOrder (0)
End With
With MMCARMS.ValidateDocFrame
.Height = 204
.Width = 354
.Left = MMCARMS.MMCIDMainBlurrImage.Left + (0.5 * MMCARMS.MMCIDMainBlurrImage.Width) - (0.5 * .Width)
.Top = MMCARMS.MMCIDMainBlurrImage.Top + (0.5 * MMCARMS.MMCIDMainBlurrImage.Height) - (0.5 * .Height) - 10
.Visible = True
.ZOrder (0)
End With
DatabaseMethods.SQLOpenDatabaseConnection DatabaseDirectory, 0
'Find definitions to fill dropdown box
SQLQueryCode = "SELECT DTT.DOC_TYPE_DESCRIPTION,DTT.DOC_TYPE_DD,DTT.DOC_GROUP_TYPE_DD FROM DOCUMENTATION_TYPE_TAB DTT WHERE DTT.DOC_GROUP_TYPE_DD=2 ORDER BY DTT.DOC_GROUP_TYPE_DD ASC, DTT.DOC_TYPE_DD ASC"
Set ActiveRecordset = DatabaseMethods.SQLQueryDatabaseRecordset(SQLQueryCode)
DatabaseMethods.SQLCloseDatabaseConnection
With MMCARMS.ValidateDocFrame.ValidateDocBorderFrame.TypeDropDownBoxDoc
'Add item to state dropdown
.AddItem "Select A Document Type"
'Load the State into the dropdown lists as items
While Not ActiveRecordset.EOF
.AddItem ActiveRecordset.Fields("DOC_TYPE_DESCRIPTION").value
ActiveRecordset.MoveNext
Wend
.ListIndex = 0
End With
End Sub
'This for bringing up the add new policy subroutine
Sub NewCommentBoxPolicy(PolicyGrouping As Integer)
'Clear All variables
MMCARMS.CommentTextBox_POL.Text = ""
MMCARMS.CommentText_POL.Caption = "Please use the textbox below to add your comment for Policy Item " & PolicyGrouping & "."
ActivePolicyGrouping = PolicyGrouping
With MMCARMS.MMCIDMainBlurrImage
.Width = MMCARMS.Width
.Height = MMCARMS.Height
.Top = 0
.Left = 0
.Visible = True
.ZOrder (0)
End With
With MMCARMS.Comment_POLFrame
.Height = 336
.Width = 468
.Left = MMCARMS.MMCIDMainBlurrImage.Left + (0.5 * MMCARMS.MMCIDMainBlurrImage.Width) - (0.5 * .Width)
.Top = MMCARMS.MMCIDMainBlurrImage.Top + (0.5 * MMCARMS.MMCIDMainBlurrImage.Height) - (0.5 * .Height)
.Visible = True
.ZOrder (0)
End With
End Sub
Sub UpdatedResolved(PolicyGrouping As Integer)
DatabaseMethods.SQLOpenDatabaseConnection DatabaseDirectory, 0
SQLQueryCode = "INSERT INTO POLICY_GROUP_RESOLUTION(MMCID,WHO_RESOLVED, WHEN_RESOLVED, POLICY_GROUPING,RESOLVED) " & _
"VALUES(" & ActiveMMCID & "," & UserNumber & ",FORMAT(#" & Now() & "#,'MM/DD/YYYY HH:mm:ss')," & PolicyGrouping & ", TRUE)"
Call DatabaseMethods.SQLWriteDatabase(SQLQueryCode)
DatabaseMethods.SQLCloseDatabaseConnection
MMCARMS.FillPolTab_MRP
End Sub
Public Function SortDictionaryByValue(dict As Object _
, Optional sortorder As XlSortOrder = xlAscending) As Object
On Error GoTo eh
Dim arrayList As Object
Set arrayList = CreateObject("System.Collections.ArrayList")
Dim dictTemp As Object
Set dictTemp = CreateObject("Scripting.Dictionary")
' Put values in ArrayList and sort
' Store values in tempDict with their keys as a collection
Dim key As Variant, value As Variant, coll As Collection
For Each key In dict
value = dict(key)
' if the value doesn't exist in dict then add
If dictTemp.Exists(value) = False Then
' create collection to hold keys
' - needed for duplicate values
Set coll = New Collection
dictTemp.Add value, coll
' Add the value
arrayList.Add value
End If
' Add the current key to the collection
dictTemp(value).Add key
Next key
' Sort the value
arrayList.Sort
' Reverse if descending
If sortorder = xlDescending Then
arrayList.Reverse
End If
dict.RemoveAll
' Read through the ArrayList and add the values and corresponding
' keys from the dictTemp
Dim item As Variant
For Each value In arrayList
Set coll = dictTemp(value)
For Each item In coll
dict.Add item, value
Next item
Next value
Set arrayList = Nothing
' Return the new dictionary
Set SortDictionaryByValue = dict
Done:
Exit Function
eh:
If Err.Number = 450 Then
Err.Raise vbObjectError + 100, "SortDictionaryByValue" _
, "Cannot sort the dictionary if the value is an object"
End If
End Function
Public Function SortDictionaryByKey(dict As Object _
, Optional sortorder As XlSortOrder = xlAscending) As Object
Dim arrList As Object
Set arrList = CreateObject("System.Collections.ArrayList")
' Put keys in an ArrayList
Dim key As Variant, coll As New Collection
For Each key In dict
arrList.Add key
Next key
' Sort the keys
arrList.Sort
' For descending order, reverse
If sortorder = xlDescending Then
arrList.Reverse
End If
' Create new dictionary
Dim dictNew As Object
Set dictNew = CreateObject("Scripting.Dictionary")
' Read through the sorted keys and add to new dictionary
For Each key In arrList
dictNew.Add key, dict(key)
Next key
' Clean up
Set arrList = Nothing
Set dict = Nothing
' Return the new dictionary
Set SortDictionaryByKey = dictNew
End Function