Why is VBA returning to the call procedure

[bassnsjp]

I'm using Office 2000 and 2003
I'm writing a macro to read input from the operator and write the response
to a word document then capture a window from another application like Access and paste that to the same document and repeat this process until the operator exits by entering X. Everything works with exception of being able to capture the desired screen. Right now I capture the inputbox screen because it is the active window. Is there a way to select another window to become the active window? Also, is there a way to list all the windows that are open regardless of what application they are associated with. For example if there is an Explorer, Word, Excel, and Powerpoint windows open can I identify how many are open and select the one that matches a title or application then capture that screen and paste it save document and repeat? Thank you in advance for your assistance. Following is an extraction of some of the code I'm using.

Option Explicit
Public Declare Sub keybd_event Lib "user32" (ByVal bvk As Byte, ByVal _
bScan As Byte, ByVal dwflags As Long, ByVal dwExtrainfo As Long)

Public Const KEYEVENTF_KEYUP = &H2
Public Const VK_SNAPSHOT = &H2C
Public Const VK_MENU = &H12

Sub ScreenCapture()
keybd_event VK_MENU, 0, 0, 0
keybd_event VK_SNAPSHOT, 0, 0, 0
keybd_event VK_SNAPSHOT, 0, KEYEVENTF_KEYUP, 0
keybd_event VK_MENU, 0, KEYEVENTF_KEYUP, 0
End Sub

Sub CaptureScreen()

Dim ansrlen As Integer
Dim Answer As String
Dim confirmX As String

Do
ansrlen = 0
Answer = InputBox("Enter color and associated number and then " & vbCr & _
"click ""Ok"" ONLY when you are ready to" & vbCr & _
"capture the screen" & vbCr & vbCr & _
"Enter X or x to exit.", "Main Capture")
ansrlen = Len(Answer)
Answer = UCase(Mid(Answer, 1, 1)) & Mid(Answer, 2, ansrlen)

If Answer = "X" Then
confirmX = MsgBox("Select ""Yes"" to confirm termination" & vbCr &
vbCr & _
"Select ""No"" to continue.", vbYesNo + vbCritical +
vbDefaultButton2, "Main Capture")
If confirmX = vbYes Then
Exit Sub
End If
Else
Selection.TypeText Answer & vbCrLf
ScreenCapture
Selection.Paste
Selection.InsertBreak Type:=wdPageBreak
End If

Loop

[lucas]

I don't understand why you want to do a screen capture. Why not just import the data into word?

[bassnsjp]

I'm capturing data that is being generated in another utility's window that processing data and I want to snapshot that data periodically and archive the data in a word document for future reference and evaluation.

[bassnsjp]

I'm using Office 2000 and 2003.
Following is an extraction of the code I'm using. The issue is when

"If ((Answer = vbCancel) Or (Answer = "") Or (Answer = "X")) Then Call ConfirmExit" is executed in GetSaveFilename subroutine and Answer does = "X" the ConfirmExit subroutine is never called and control immediately returns to the MainCapture procedure. By chance is confirm or ConfirmExit reserved words in VBA? I'm puzzled why this keeps happening and have wasted too much time on what should be a very simple procedure. Any assistance would be greatly appreciated.

Sub MainCapture()

Call GetSaveFilename
If exitproc Then Exit Sub
...
...
End Sub

Sub GetSaveFilename()

filename = ""
WindowTitle = "Get Filename"

Do
Answer = InputBox("Enter filename to save survey information." & vbCr & vbCr & "Hit Enter, Cancel or type X or x to exit.", WindowTitle)

If Answer = "x" Then Answer = "X"
If ((Answer = vbCancel) Or (Answer = "") Or (Answer = "X")) Then Call ConfirmExit
If exitproc Then Exit Sub
...
...
Loop
End Sub

Sub ConfirmExit()

exitproc = False
confirm = MsgBox("Select ""Yes"" to confirm termination" & vbCr & vbCr & _
"Select ""No"" to continue processing.", vbYesNo _
vbDefaultButton2, WindowTitle)
If confirm = vbYes Then exitproc = True

End Sub

[Paul_Hossler]

1. You have a lot of scope issues, unless there's more that just what you have posted.

Use Option Explicit at the top of your module to force variables to be Dim-ed.

For example, exitproc is used in all 3 subs, but it's not the same 'exitproc' -- same name, different scope -- so it's Empty most of the time: it 'goes away' when you leave each Sub


2. This needs a + after the vbYesNo


Select ""No"" to continue processing.", vbYesNo _
vbDefaultButton2, WindowTitle)




3. Something like this maybe, with the Option Explicit and exitproc is now scoped to be the whole module, so the 3 subs use the same (only) exitproc


Option Explicit
Dim exitproc As Boolean
Const WindowTitle As String = "Get Filename"
Sub MainCapture()

Call GetSaveFilename

If exitproc Then Exit Sub
End Sub
Sub GetSaveFilename()
Dim FileName As String, Answer As Variant
FileName = ""
Do
Answer = InputBox("Enter filename to save survey information." & _
vbCr & vbCr & "Hit Enter, Cancel or type X or x to exit.", WindowTitle)
If Answer = "x" Then Answer = "X"
If ((Answer = vbCancel) Or (Answer = "") Or (Answer = "X")) Then Call ConfirmExit
If exitproc Then Exit Sub
Loop
End Sub
Sub ConfirmExit()
Dim confirm As String
exitproc = False
confirm = MsgBox("Select ""Yes"" to confirm termination" & vbCr & vbCr & _
"Select ""No"" to continue processing.", vbYesNo + _
vbDefaultButton2, WindowTitle)

If confirm = vbYes Then exitproc = True
End Sub


Paul

[bassnsjp]

Paul,

I was able to find a copy of a recent version of the code, which is experiencing the problem discribed in the original posting.


Option Explicit
Public Answer As String ' Reads input from user
Public ansrlen As Integer ' Length of answer provided user
Public confirm As String ' User response confirmation
Public firsttime As Boolean ' Flag to indicate if its the first time data is written
Public tasknam As Task ' Task name of programs that are active
Public task1nam As String ' First task name of interest
Public task1cnt As Integer ' Number of tasks open with the same first task name
Public task2nam As String ' Second task name of interest
Public task2cnt As Integer ' Number of tasks open with the same second task name
Public taskcnt As Integer ' Total number of tasks that are active (debug)
Public filename As String ' Filename to save survey data
Public dirpath As String ' Path associated with the file
Public fullpath As String ' Path and filename combined
Public exitproc As Boolean ' Flag to determine whether to exit the process
Public subtitle As String ' Used to post title on input or msg window
Public template As String ' Filename of default template
Private Declare Sub keybd_event Lib "user32" (ByVal bvk As Byte, ByVal _
bScan As Byte, ByVal dwflags As Long, ByVal dwExtrainfo As Long)

Private Const KEYEVENTF_KEYUP = &H2
Private Const VK_SNAPSHOT = &H2C
Private Const VK_MENU = &H12
Sub ScreenCapture()
' This subroutine captures the current active window to the clipboard
keybd_event VK_MENU, 0, 0, 0
keybd_event VK_SNAPSHOT, 0, 0, 0
keybd_event VK_SNAPSHOT, 0, KEYEVENTF_KEYUP, 0
keybd_event VK_MENU, 0, KEYEVENTF_KEYUP, 0

End Sub

Sub MainCapture()
' This is the main subroutine of the CaptureScreen macro. This subroutine
' prompts the user for input, stores the input data to a file, captures the
' screen associated with program "XYZ" and paste that into the file. This
' process is repeated until the user terminates the macro.
' Set default value to variables
task1cnt = 0
task2cnt = 0
firsttime = False
dirpath = "C:\SurveyData\"
exitproc = False
template = "SurveyCaptureScreenTemplate"
subtitle = "Main Capture"
' If an error is encountered continue so that it can be detected.
On Error Resume Next
' Call CheckDirPath function to determine if directory exists
exitproc = False
Call CheckDirPath
' Check to see if user wishes to exit program
If exitproc Then Exit Sub
' Call GetSaveFilename to get the filename to save the survey output data
exitproc = False
Call GetSaveFilename
' Check to see if user wishes to exit program
If exitproc Then Exit Sub
' Main subroutine to get color and associated number
Do
ansrlen = 0
Answer = InputBox("Enter color and associated number and then " & vbCr & _
"click ""Ok"" ONLY when you are ready to" & vbCr & _
"capture the screen" & vbCr & vbCr & _
"Hit Enter, Cancel or type X or x to exit.", subtitle)
ansrlen = Len(Answer)
Answer = UCase(Mid(Answer, 1, 1)) & Mid(Answer, 2, ansrlen)
Debug.Print "Answer:" & Answer
If ((Answer = vbCancel) Or (Answer = "") Or (UCase(Answer) = "X")) And ConfirmExit Then
exitproc = True
Exit Sub
End If
If Answer = "X" Then
confirm = MsgBox("Select ""Yes"" to confirm termination" & vbCr & vbCr & _
"Select ""No"" to continue.", vbYesNo + vbCritical + vbDefaultButton2, "Main Capture")
If confirm = vbYes Then
Exit Sub
End If
Else
Selection.TypeText Answer & vbCrLf
ScreenCapture
Selection.Paste
Selection.InsertBreak Type:=wdPageBreak
End If

Loop
End Sub
Sub GetSaveFilename()
' This subroutine prompts user for the filename to save data to
subtitle = "Get Filename"
filename = ""
' Prompt user for the filename and check to see if they wish to terminate the process
Do
Answer = InputBox("Enter filename to save survey output data." & vbCr & vbCr & _
"Hit Enter, Cancel or type X or x to exit.", subtitle)
If ((Answer = vbCancel) Or (Answer = "") Or (UCase(Answer) = "X")) And ConfirmExit Then
exitproc = True
Exit Sub
End If
filename = Answer
' Check to see if the filename entered is the same as the default template.
' If so request user to enter another filename.
If filename = template Then
MsgBox ("Filename cannot be the same as the SurveyCaptureScreenTemplate." & vbCr & _
"Please enter another filename.")
Else
' Check to see if file already exists and if so, notify user
' and inquire to overwrite or not
fullpath = pathname & filename
If Dir(filename) = vbNullString Then
ActiveDocument.SaveAs (filename)
Else
Answer = MsgBox("File already exists do you wish to overwrite the file?", vbCr & _
vbYesNo, subtitle)
If Answer = vbYes Then
confirm = MsgBox("Confirm you wish to overwrite the file?", vbCr & _
vbYesNo, subtitle)
If confirm = vbYes Then
ActiveDocument.SaveAs (filename)
End If
End If
End If
End If
Loop

End Sub
Sub CheckDirPath()
' This subroutine checks to see if the default directory path exists.
' If it does not then prompt the user to create a directory.
subtitle = "Check Directory Path"
Do
If Not Dir(dirpath, vbDirectory) <> "" Then
Answer = MsgBox("Directory " & "" & dirpath & "" & " does not exist." & vbCr & vbCr & _
"Do you wish to create or use another directory?" & vbCr & _
"Select Yes to create "" & dirpath & "" directory." & vbCr & _
"Select No to create or use another directory.", vbYesNo, subtitle)
If Answer = vbYes Then
MkDir (dirpath)
If Err.Number <> 0 Then
MsgBox ("Following error was encountered in creating" & _
" "" & dirpath & "" :" & vbCr & vbCr & _
"Error: " & Err.Number & " " & Err.Description & vbCr & vbCr & _
"Create or use another directory.")
End If
Else
Answer = MsgBox("Do you wish to create another directory?" & _
vbCr, vbYesNo, subtitle)
If Answer = vbYes Then
dirpath = InputBox("Enter directory to create, please include drive" & vbCr & _
"in the pathname (for example ""C:\xyz"")" & vbCr & _
"Hit Enter, Cancel or type X or x to exit.", subtitle)
If ((Answer = vbCancel) Or (Answer = "") Or (UCase(Answer) = "X")) And ConfirmExit Then Exit Sub
Else
Answer = MsgBox("Do you wish to use another directory?" & _
vbCr, vbYesNo, subtitle)
If Answer = vbYes Then
dirpath = InputBox("Enter directory to use, please include drive" & vbCr & _
"in the pathname (for example ""C:\xyz"")" & vbCr & _
"Hit Enter, Cancel or type X or x to exit.", subtitle)
If ((Answer = vbCancel) Or (Answer = "") Or (UCase(Answer) = "X")) And ConfirmExit Then Exit Sub
Else
MsgBox ("A directory must be selected." & _
"Please use or create a directory.")
End If
End If
End If
Else
Exit Sub
End If
Loop
End Sub
Function ConfirmExit() As Boolean
' This function determines whether the user wishes to exit the program

subtitle = "Confirm Exit"
confirm = MsgBox("Select ""Yes"" to confirm termination" & vbCr & vbCr & _
"Select ""No"" to continue.", vbYesNo + vbCritical + _
vbDefaultButton2, subtitle)
If confirm = vbYes Then
exitproc = True
ConfirmExit = True
Exit Sub
Else
ConfirmExit = False
End If
End Function


Edited 23-Apr-09 by geekgirlau. Reason: insert vba tags

[fumei]

Please use the VBA code tags. Thanks.