I have the following code. I'm looking to create a resume button. Problem is that my stack is lost when I exit excel. How would I approach this? Any ideas would be appreciated
Code:
Option Explicit
Dim m_Prev_QID() As Integer
Dim m_Next_QID() As Integer
Dim m_QID As Integer
Dim m_ItemNo As Integer
Dim m_Question As String
Dim m_Response As String
Dim m_Validation As String
Dim m_PCSOutput As String
Dim m_TotalUniqueQuestions As Integer
Dim strResponse As String
Private Sub cmbOptions_Change()
'Get the Option Item Number from the list
If cmbOptions.ListIndex <> -1 Then
m_ItemNo = cmbOptions.ListIndex + 1
m_Response = cmbOptions.Value
cmdNext.Enabled = True
End If
End Sub
Private Sub cmdEnd_Click()
Unload Me
End Sub
Private Sub cmdNext_Click()
If txtInput.Visible Then
Select Case m_Validation
Case "D": 'Date
If Not IsDate(m_Response) Then
MsgBox "Please enter a valid date !", vbCritical
txtInput.SetFocus
Exit Sub
Else
m_Response = Format(m_Response, "dd mm yyyy") 'changed in version 7.34. May need to add both date formats
End If
Case "P" 'Percentage
If Not IsNumeric(m_Response) Then
MsgBox "Please enter a valid % !", vbCritical
txtInput.SetFocus
Exit Sub
Else
m_Response = Format(m_Response, "0.00%")
End If
Case "N" 'Numeric - Currency - Term Lenght - Age etc
If Not IsNumeric(m_Response) Then
MsgBox "Please enter a valid Number !", vbCritical
txtInput.SetFocus
Exit Sub
Else
m_Response = CDbl(m_Response)
End If
Case "T": 'Free Flow Text
m_Response = DoSpellCheck(m_Response)
Case Else:
m_Response = m_Response
End Select
End If
If m_PCSOutput = "4v1.0" Then
UserCalendar.Show
txtInput.Value = Format(UserCalendar.Calendar1.Value, "dd mm yyyy")
Unload UserCalendar
End If
If m_PCSOutput = "5v1.0" Then
UserCalendar.Show
txtInput.Value = Format(UserCalendar.Calendar1.Value, "dd mm yyyy")
Unload UserCalendar
End If
If m_PCSOutput = "5av1.0" Then
UserCalendar.Show
txtInput.Value = Format(UserCalendar.Calendar1.Value, "dd mm yyyy")
Unload UserCalendar
End If
If m_PCSOutput = "40v1.0." Then
UserCalendar.Show
txtInput.Value = Format(UserCalendar.Calendar1.Value, "dd mm yyyy")
Unload UserCalendar
End If
If m_PCSOutput = "41v1.0" Then
UserCalendar.Show
txtInput.Value = Format(UserCalendar.Calendar1.Value, "dd mm yyyy")
Unload UserCalendar
End If
If m_PCSOutput = "60v1.0" Then
UserCalendar.Show
txtInput.Value = Format(UserCalendar.Calendar1.Value, "dd mm yyyy")
Unload UserCalendar
End If
If m_PCSOutput = "40v1.0" Then
UserCalendar.Show
txtInput.Value = Format(UserCalendar.Calendar1.Value, "dd mm yyyy")
Unload UserCalendar
End If
End Sub
Private Sub CmdPrevQuestion_Click()
End Sub
Public Sub Cancel()
userQuestions.Show
If m_QID = 1 Then
m_QID = 1
CmdPrevQuestion.Enabled = False
Else
m_QID = QID_Prev(m_Question)
Call Delete_LastRow
Call Question_load
CmdPrevQuestion.Enabled = True
End If
If m_PCSOutput = "G7A" Then
lblChar.Visible = False
End If
If m_PCSOutput = "G7" Then
lblChar.Visible = True
End If
If m_PCSOutput = "1v1.0" Then
lblChar.Visible = False
End If
If m_PCSOutput = "2v1.0" Then
lblChar.Visible = True
End If
If m_PCSOutput = "2v1.0 " Then
lblChar.Visible = False
End If
If m_PCSOutput = "2v1.0" Then
lblChar.Visible = True
End If
End Sub
Private Sub txtInput_Change()
lblChar.Caption = Len(Replace(txtInput, "", "")) & " Characters used."
cmdNext.Enabled = (txtInput.Text <> "")
'm_Validation
m_Response = txtInput.Text
End Sub
Private Sub UserForm_Initialize()
m_QID = 1
m_TotalUniqueQuestions = TotalQuestions
cmbOptions.Value = ""
Call Question_load
End Sub
Private Sub Question_load()
Dim intTotalOptions As Integer
Dim strQInfo(4) As String
Dim strOptionsID() As String
Dim strOptions() As String
Dim intOptionsControl As Integer
Dim intOptions As Integer
ReDim m_Next_QID(0)
ReDim m_Prev_QID(0)
Call Question_Detail(m_QID, strQInfo, intTotalOptions, strOptionsID, strOptions, m_Next_QID, m_Prev_QID, intOptionsControl)
'Update Memory Variables
m_Question = strQInfo(1)
m_Validation = strQInfo(3)
m_PCSOutput = strQInfo(4) 'Get PCS Output Information
m_Response = QuestionAnswer(m_Question)
m_ItemNo = 1
'Load Controls with Data
Dim n As Long
For n = 1 To 10
Label2.Visible = Not Label2.Visible
DoEvents
Me.Repaint
Me.Label2.Width = 361.1 * (m_QID / m_TotalUniqueQuestions)
Me.Label2.Caption = Format((m_QID / m_TotalUniqueQuestions), "0.0%")
Me.lblQID.Caption = m_QID
Me.lblQuestion.Caption = m_Question
Me.LblDesc.Caption = strQInfo(2)
Next n
'Hide all Controls
cmbOptions.Visible = False
txtInput.Visible = False
'Decide which control should be displayed
Select Case intOptionsControl
Case CTRL_OPTION:
Case CTRL_CHECKBOX:
Case CTRL_LISTBOX:
Case CTRL_COMBOBOX: 'Set Combobox
With cmbOptions
.Clear
.Visible = True
For intOptions = 1 To intTotalOptions
.AddItem strOptions(intOptions)
If strOptions(intOptions) = m_Response Then .ListIndex = intOptions - 1
Next intOptions
End With
Case CTRL_TEXTBOX:
txtInput.Value = m_Response
txtInput.Visible = True
Case Else:
txtInput.Visible = True
End Select
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Module
Option Explicit
Public Const CTRL_OPTION = 1
Public Const CTRL_CHECKBOX = 2
Public Const CTRL_LISTBOX = 3
Public Const CTRL_COMBOBOX = 4
Public Const CTRL_TEXTBOX = 5
Private Type BrowseInfo
hwndOwner As Long
pidlRoot As Long
sDisplayName As String
sTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Private Declare Function SHBrowseForFolder Lib "Shell32.dll" (bBrowse As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "Shell32.dll" (ByVal lItem As Long, ByVal sDir As String) As Long
'Get Total Unique Questions
Function TotalQuestions() As Integer
TotalQuestions = Application.CountA(shQuestions.Columns(6))
End Function
'This will return to Last question
Function QID_Prev(Question As String) As Integer
QID_Prev = 0
On Error Resume Next
QID_Prev = Application.WorksheetFunction.Match(Question, shOutput.Range("$B$1:$B$5000"), 0) - 1
If QID_Prev = 0 Then QID_Prev = Application.CountA(shOutput.Columns(1))
QID_Prev = CInt(shOutput.Range("A" & QID_Prev).Value)
End Function
'This will search Output Sheet and pull result value if available
Function QuestionAnswer(Question As String) As String
QuestionAnswer = ""
On Error Resume Next
QuestionAnswer = Application.WorksheetFunction.VLookup(Question, shOutput.Range("$B$1:$C$5000"), 2, False)
End Function
'Save data to output worksheet
Sub SaveData(ByVal intQID As Integer, _
ByVal strQuestion As String, _
ByVal strResponse As String, _
Optional ByVal strPCS As String)
Dim intRowNo As Integer
'Get the Last Row in list
intRowNo = Application.CountA(shOutput.Columns(1)) + 1
'Get RowNO if Data exist
On Error Resume Next
intRowNo = Application.WorksheetFunction.Match(strQuestion, shOutput.Range("$B$1:$B$5000"), 0)
With shOutput
.Range("A" & intRowNo) = intQID
.Range("B" & intRowNo) = strQuestion
.Range("C" & intRowNo) = strResponse
If strPCS <> "" Then shOutput.Range("D" & intRowNo) = strPCS
End With
End Sub
'This will pull required information from Questions Tab
'using given Question ID
Sub Question_Detail(ByVal QID As Integer, _
ByRef qInfo() As String, _
ByRef qOptCount As Integer, _
ByRef qOptID() As String, _
ByRef qOptNote() As String, _
ByRef qOptNextID() As Integer, _
ByRef qOptPrevID() As Integer, _
ByRef qOptControl As Integer)
Dim intRowNo As Integer
Dim intTotalRow As Integer
On Error Resume Next
'Get Total Options Count
intTotalRow = Application.CountA(shQuestions.Columns(2))
'Locate the 1st RowNo of Question
intRowNo = Application.WorksheetFunction.Match(QID, shQuestions.Range("A:A"), 0)
'Get the Display Control Type
qOptControl = CInt(shQuestions.Range("F" & intRowNo).Value)
'Get Question Text
qInfo(1) = CStr(shQuestions.Range("B" & intRowNo).Value)
'Get Question Descriptions
qInfo(2) = CStr(shQuestions.Range("G" & intRowNo).Value)
'Get Validation Type - applicable for Text Control Only
qInfo(3) = CStr(shQuestions.Range("H" & intRowNo).Value)
'Get PCS Output Information
qInfo(4) = CStr(shQuestions.Range("J" & intRowNo).Value)
qOptCount = 0
'Get all options for matching qID
While (intRowNo <= intTotalRow) And (CInt(shQuestions.Range("A" & intRowNo).Value) = QID)
'Increment Option Counter and resize the array length
qOptCount = qOptCount + 1
ReDim Preserve qOptNote(qOptCount)
ReDim Preserve qOptID(qOptCount)
ReDim Preserve qOptNextID(qOptCount)
ReDim Preserve qOptPrevID(qOptCount)
qOptID(qOptCount) = CStr(shQuestions.Range("C" & intRowNo).Value)
qOptNote(qOptCount) = CStr(shQuestions.Range("D" & intRowNo).Value)
qOptNextID(qOptCount) = CInt(shQuestions.Range("E" & intRowNo).Value)
qOptPrevID(qOptCount) = CInt(shQuestions.Range("A" & intRowNo).Value)
intRowNo = intRowNo + 1
Wend
End Sub
' Deletes Last Row when Prev Button Selected. Ensures the Correct Question Paths are always Maintained
Function Delete_LastRow()
Application.ScreenUpdating = False
Dim LastRow As Long
LastRow = Sheets("output").Range("A" & Rows.Count).End(xlUp).row
Sheets("output").Rows(LastRow).Delete
Application.ScreenUpdating = True
End Function
