I've tried just about every option of modeless possible to get this to work I just cannot get it figured out. What I have is a Userform ( Main_Window ) that has a script, and on command button it executes Master_Flex_Filter_Generate()
In that code I have
' Connect and execute the SQL
rs.Open sqlString, conn, adOpenStatic
' Check if we have data.
If Not rs.EOF Then
' Dump column names in first row.
For i = 0 To rs.Fields.count - 1
ActiveSheet.Cells(1, i + 1) = rs.Fields(i).Name
Next i
Do
' Transfer results beginning at A2 from rs
ActiveSheet.Range("A2").CopyFromRecordset rs
Loop Until rs.EOF
' Close the recordset
rs.Close
' Define Record_Count as the amount of records returned. Subtract 1 for the header
Record_Count = Cells(Rows.count, "A").END(xlUp).Row - 1
' Return box on success
Answer = MsgBox((Record_Count & " Records returned") & vbCrLf & vbCrLf & "Reminder" & vbCrLf & "- This data set is already defined as a range. This allows you to create a new pivot table and use the named range: " & ActiveSheet.Name & vbCrLf & vbCrLf & "Do you want to create a Pivot Table from this data?", vbYesNo + vbQuestion, "Query generated succesfully")
' close user form
Unload mod_loading
Unload Main_Window
' Clean up
If CBool(conn.State And adStateOpen) Then conn.Close
Set conn = Nothing
Set rs = Nothing
'Now lets define this data as a range for pivot table use
Dim ActSheet As Worksheet
Dim ActSheetName As String
'This sets up an object reference to the activesheet
Set ActSheet = Sheets(ActiveSheet.Name)
'This places a string value in the variable
ActSheetName = ActiveSheet.Name
Set wb = ActiveWorkbook
Set ws = ActiveSheet
Set sheetname = ActiveWorkbook.ActiveSheet
ws.Range("A1").Select
ActiveWorkbook.Names.Add Name:="data", RefersToR1C1:= _
"=OFFSET(R1C1,0,0,COUNTA(C1),COUNTA(R1))"
wb.Names("data").Name = ActSheetName
'Filter, freeze pain, and align columns
Rows("1:1").Select
Selection.AutoFilter
Selection.Font.Bold = True
Columns("A:IV").AutoFit
With ActiveWindow
.SplitColumn = 0
.SplitRow = 1
End With
ActiveWindow.FreezePanes = True
'Take answer form msgbox and do something with it
If Answer = vbYes Then
'If yes, create pivot table
Sheets("Pivot").Select
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
"data", Version:=xlPivotTableVersion14).CreatePivotTable TableDestination _
:="Pivot!R1C1", TableName:="PivotTable1", DefaultVersion:= _
xlPivotTableVersion14
Sheets("Pivot").Select
Cells(1, 1).Select
End If
Else
mod_loading.Hide
MsgBox "Error: No records returned for your criteria.", vbCritical
End If
This form works perfectly as is here. I have another Userform called mod_loading that looks like this
Sub UserForm_Activate()
DoEvents
Do
mod_loading.loading_beag.Visible = False
mod_loading.loading_splines.Visible = True
Sleep 2000
DoEvents
mod_loading.loading_splines.Visible = False
mod_loading.loading_sheep.Visible = True
Sleep 5000
DoEvents
mod_loading.loading_sheep.Visible = False
mod_loading.loading_meteor.Visible = True
Sleep 5000
DoEvents
mod_loading.loading_meteor.Visible = False
mod_loading.loading_ozone.Visible = True
Sleep 5000
DoEvents
mod_loading.loading_ozone.Visible = False
mod_loading.loading_terrain.Visible = True
Sleep 5000
DoEvents
mod_loading.loading_terrain.Visible = False
mod_loading.loading_gravity.Visible = True
Sleep 5000
DoEvents
mod_loading.loading_gravity.Visible = False
mod_loading.loading_advisor.Visible = True
Sleep 5000
DoEvents
mod_loading.loading_advisor.Visible = False
mod_loading.loading_pool.Visible = True
Sleep 5000
DoEvents
mod_loading.loading_pool.Visible = False
mod_loading.loading_leaks.Visible = True
Sleep 5000
DoEvents
mod_loading.loading_leaks.Visible = False
mod_loading.loading_beag.Visible = True
Sleep 5000
DoEvents
Loop
End Sub
Both of these forms work as is, where I'm having the problem is placing mod_loading.Show anywhere in Master_Flex_Filter_Generate(). No matter what I set for modeless the mod_loading will run until it completely finishes. It won't let the code in Main_Window to continue running, so it halts that code. Any ideas? I was thinking it's perhaps because I'm not playing mod_loading.Show inside a loop, but since my connection string doesn't have a loop I can't figure out how to do it.
I placed the code inside If Not rs.EOF THEN but 99% of the code loads on rs.Open which is outside of the loop.
EDIT
Okay so I have changed my script all around and have placed all SQL logic inside the userform for the loading dialog. So I have Main_Window which is the form, then it calls the sub from the loading userform which pops up just fine. So I now have the loading dialog pop up and goes away just fine as intended. My only problem is now, it doesn't loop through my sleep commands. It just remains on the very first one.
Here is my code for the loading userform
Sub UserForm_Activate()
DoEvents
Call Master_Flex_Filter_Generate
DoEvents
If Cancel = True Then
Unload loading_masterflexfilter
Exit Sub
End If
loading_masterflexfilter.loading_beag.Visible = False
loading_masterflexfilter.loading_splines.Visible = True
Sleep 500
DoEvents
If Cancel = True Then
Unload loading_masterflexfilter
Exit Sub
End If
loading_masterflexfilter.loading_splines.Visible = False
loading_masterflexfilter.loading_sheep.Visible = True
Sleep 1000
DoEvents
If Cancel = True Then
Unload loading_masterflexfilter
Exit Sub
End If
loading_masterflexfilter.loading_sheep.Visible = False
loading_masterflexfilter.loading_meteor.Visible = True
Sleep 1000
DoEvents
If Cancel = True Then
Unload loading_masterflexfilter
Exit Sub
End If
loading_masterflexfilter.loading_meteor.Visible = False
loading_masterflexfilter.loading_ozone.Visible = True
Sleep 1000
DoEvents
If Cancel = True Then
Unload loading_masterflexfilter
Exit Sub
End If
loading_masterflexfilter.loading_ozone.Visible = False
loading_masterflexfilter.loading_terrain.Visible = True
Sleep 1000
DoEvents
If Cancel = True Then
Unload loading_masterflexfilter
Exit Sub
End If
loading_masterflexfilter.loading_terrain.Visible = False
loading_masterflexfilter.loading_gravity.Visible = True
Sleep 1000
DoEvents
If Cancel = True Then
Unload loading_masterflexfilter
Exit Sub
End If
loading_masterflexfilter.loading_gravity.Visible = False
loading_masterflexfilter.loading_advisor.Visible = True
Sleep 1000
DoEvents
If Cancel = True Then
Unload loading_masterflexfilter
Exit Sub
End If
loading_masterflexfilter.loading_advisor.Visible = False
loading_masterflexfilter.loading_pool.Visible = True
Sleep 1000
DoEvents
If Cancel = True Then
Unload loading_masterflexfilter
Exit Sub
End If
loading_masterflexfilter.loading_pool.Visible = False
loading_masterflexfilter.loading_leaks.Visible = True
Sleep 1000
DoEvents
If Cancel = True Then
Unload loading_masterflexfilter
Exit Sub
End If
loading_masterflexfilter.loading_leaks.Visible = False
loading_masterflexfilter.loading_beag.Visible = True
Sleep 1000
DoEvents
End Sub
Related
I have several transactions to automate and then paste into several tables.
My code works for my first transaction but for the others I put the same code I just deleted the sheets in which I put it and it doesn't work at all.
Public SapGuiAuto, WScript, msgcol
Public objGui As GuiApplication
Public objConn As GuiConnection
Public objSess As GuiSession
Public objSBar As GuiStatusbar
Public objSheet As Worksheet
Dim W_System
Const fpath = "C:\Users\p100789\Documents\SAP\SAP GUI"
Const ffilename = "text.txt"
Sub OpenCSVFile()
'
' Load the CSV extract
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & fpath & "\" & ffilename, Destination:=Range("$A$1"))
.Name = "text"
.FieldNames = True
.RowNumbers = False
[...]
End With
With ActiveSheet
.Columns(1).EntireColumn.Delete
'delete first column
.Columns(1).EntireColumn.Insert
.Rows("1:11").EntireRow.Delete 'delete first 9 rows
End With
End Sub
Function Attach_Session() As Boolean
Dim il, it
Dim W_conn, W_Sess
If W_System = "" Then
Attach_Session = False
Exit Function
End If
If Not objSess Is Nothing Then
If objSess.Info.SystemName & objSess.Info.Client = W_System Then
Attach_Session = True
Exit Function
End If
End If
If objGui Is Nothing Then
Set SapGuiAuto = GetObject("SAPGUI")
Set objGui = SapGuiAuto.GetScriptingEngine
End If
For il = 0 To objGui.Children.Count - 1
Set W_conn = objGui.Children(il + 0)
For it = 0 To W_conn.Children.Count - 1
Set W_Sess = W_conn.Children(it + 0)
If W_Sess.Info.SystemName & W_Sess.Info.Client = W_System Then
Set objConn = objGui.Children(il + 0)
Set objSess = objConn.Children(it + 0)
Exit For
End If
Next
Next
If objSess Is Nothing Then
MsgBox "No active session to system " + W_System + ", or scripting is not
enabled.", vbCritical + vbOKOnly
Attach_Session = False
Exit Function
End If
If IsObject(WScript) Then
WScript.ConnectObject objSess, "on"
WScript.ConnectObject objGui, "on"
End If
Set objSBar = objSess.findById("wnd[0]/sbar")
objSess.findById("wnd[0]").maximize
Attach_Session = True
End Function
Public Sub RunGUIScript()
Dim W_Ret As Boolean
Dim Société As String
Sheets("Extraction").Select
Société = Range("b9")
' Connect to SAP
W_Ret = Attach_Session
If Not W_Ret Then
Exit Sub
End If
On Error GoTo myerr
[....script]
Exit Sub
myerr:
MsgBox "Error occured while retrieving data", vbCritical + vbOKOnly
End Sub
Sub StartExtract()
' Set the sid and client to connect to
W_System = "P10320"
' Run the GUI script
RunGUIScript
' End the GUI session
objSess.EndTransaction
'effacer contenu feuille temp
Sheets("temp").Select
Cells.Select
Selection.Delete Shift:=xlUp
' Switch to the worksheet where the data is loaded to
Sheets("temp").Select
' Load the CSV file
OpenCSVFile
[...]
' Update the time and date on the control worksheet
Sheets("Extraction").Select
Cells(2, 2).Value = Now()
in short, to automate another transaction I put the same code after, by filling the script with the new script. It doesn't work, does anyone have a solution?
I have a userform. The idea is to check if there are any 'True' values in column(15) in 'Admin' sheet. If there is at least a single 'True' value, then the userform will remain open and continue its operation.
However, if there is not a single 'True' found, then the userform will display a message and close the userform automatically.
Private Sub Userform_initialize()
Dim LR As Long
LR = Sheets("Project_Name").Cells(Rows.Count, "B").End(xlUp).Row
With Worksheets("Admin")
For i = 7 To LR
If .Cells(i, 15) = "True" Then
Exit For
Else
MsgBox ("No values found")
Exit For
Unload Me
End If
Next i
End With
''' more code'''
End Sub
Everything on my userform works as expected, except for the fact I am unable to make it close itself automatically. I.e. Unload Me is not working.
Any advice?
You should check your criteria before you even display the UserForm. You can add this as a condition wherever you are calling the UserForm. No need to open the form just to immediately close it when you can check before-hand.
On the first instance of True, the UserForm will open, and exit the sub. If the loop completes (finds no True values), the sub will proceed to your MsgBox
Sub OpenForm
With Worksheets("Admin")
For i = 7 To LR
If Cells(i,15) = "True" then
Userform.Show
Exit Sub
End If
Next i
End With
MsgBox "No Values Found"
End Sub
Please look at your code; you have put Unload Me is after Exit For
'Here is something for you to ponder on .........
'Public enum type to add a set of particular vbKeys to the standard key set
Public Enum typePressKeys
vbNoKey = 0
vbExitTrigger = -1
vbAnswerKey = 100
vbLaunchKey = 102
vbPrevious = 104
vbNext = 106
vbSpecialAccessKey = 108
End Enum
Public Sub doSomethingWithMyUserform()
Dim stopLoop As Boolean, testVal As Boolean, rngX As Range, LR As Long
LR = ThisWorkbook.Sheets("Project_Name").Cells(Rows.Count, "B").End(xlUp).Row
Set rngX = ThisWorkbook.Worksheets("Admin")
testVal = False
With rngX 'Your sub can do the check here
For i = 7 To LR
If .Cells(i, 15) = "True" Then
testVal = True
Exit For
End If
Next i
End With
If testVal Then
Load UserForm1
With UserForm1
.Caption = "Something"
.Tag = vbNoKey
.button_OK.SetFocus 'Assuming you have a OK button on Userform1
End With
UserForm1.Show
stopLoop = False
Do
If UserForm1.Tag = vbCancel Then
'Do something perhaps
Unload UserForm1
stopLoop = True
ElseIf UserForm1.Tag = vbOK Then
'Do something specific
Unload UserForm1
stopLoop = True
Else
stopLoop = False
End If
Loop Until stopLoop = True
else
MsgBox "No values found"
End If
'Here you can close the way you want
Set rngX = Nothing
End Sub
enter code here
i currently have a problem with a simple login form in excel (VBA), when having an error, continuing and having another error it still gives me two more MsgBoxes with errors but with the "Unload Me" and "Goto Ende" it should close itself completely.
Any guesses why this isn't working? I know this is very basic and probably very redundant, but it should still work.
Public Name As Variant
Public Password As Variant
Private Sub Btn_Register_Cancel_Click()
Unload Me
End Sub
Private Sub Btn_Register_Register_Click()
Start:
Dim Error As Integer
Error = 0
Name = Tbx_Register_Name.Value
Password = Tbx_Register_Password.Value
'Check for Name, Password, Password2 if empty
If Tbx_Register_Name.Value = "" Then
Error = MsgBox("Please enter a username.", _
vbRetryCancel, "Error")
If Error = 2 Then
Unload Me
GoTo Ende
Else
Application.ScreenUpdating = False
Register.Hide
Register.Show
Application.ScreenUpdating = True
GoTo Start
End If
ElseIf Tbx_Register_Password.Value = "" Then
Error = MsgBox("Please enter a password.", _
vbRetryCancel, "Error")
If Error = 2 Then
Unload Me
GoTo Ende
Else
Application.ScreenUpdating = False
Register.Hide
Register.Show
Application.ScreenUpdating = True
GoTo Start
End If
ElseIf Tbx_Register_Password2.Value = "" Then
Error = MsgBox("This field cannot be empty.", _
vbRetryCancel, "Error")
If Error = 2 Then
Unload Me
GoTo Ende
Else
Application.ScreenUpdating = False
Register.Hide
Register.Show
Application.ScreenUpdating = True
GoTo Start
End If
End If
With Workbooks("General Makro.xlsx").Worksheets("User")
'Check for Username match in registration list
For i = 1 To 100
If .Cells(i, 1).Value = Name Then
Error = MsgBox("This username is already taken.", _
vbRetryCancel, "Error")
If Error = 2 Then
Unload Me
i = 100
GoTo Ende
Else
Application.ScreenUpdating = False
Register.Hide
Register.Show
Application.ScreenUpdating = True
GoTo Start
End If
End If
Next i
End With
'Check for the passwords to match
If Tbx_Register_Password.Value = Tbx_Register_Password2.Value Then
With Workbooks("General Makro.xlsx").Worksheets("User")
For i = 1 To 100
If .Cells(i, 1) = "" Then
.Cells(i, 1).Value = Name
.Cells(i, 2).Value = Password
Tbx_Register_Password.Value = ""
Tbx_Register_Password2.Value = ""
Application.ScreenUpdating = False
Register.Hide
Login.Show
Tbx_Login_Name.Value = .Cells(i, 1).Value
Tbx_Login_Password.Value = .Cells(i, 2).Value
Application.ScreenUpdating = True
i = 100
GoTo Ende
End If
Next i
End With
Else
Error = MsgBox("The passwords have to match!", vbRetryCancel, "Error")
If Error = 2 Then
Unload Me
GoTo Ende
Else
Application.ScreenUpdating = False
Register.Hide
Register.Show
Application.ScreenUpdating = True
GoTo Start
End If
End If
Ende:
End Sub
Edit: I Actually Tried to do the 2nd UserForm for the login, and i happen to get the same problem there. Everything works just fine, until i close the whole program, then the error-message appears again. Am i unloading the userform incorrect? Maby the login userform says open and continues when everything is getting closed.
Edit 2: I could just turn off alerts but that would be an ugly solution and definitely nothing i want to implement on every close button in the program.
You can verify blank values in textboxes with this:
If TextBox.Text = "" Then
MsgBox "Is blank!"
Unload Me
GoTo Ende
End If
'Your code
Ende: Exit Sub
To verify the username and password in a database, you can do this:
Dim sh As Worksheet
Dim LastRow As Long
Dim UserRange As Range
Dim UserMatch As Range
Set sh = ThisWorkbook.Sheets("database")
LastRow = sh.Range("A" & Rows.Count).End(xlUp).Row
Set UserRange = sh.Range("A1:A" & LastRow)
Set UserMatch = UserRange.Find(What:=UserTextBox.Text, LookIn:=xlValues)
If Not UserMatch Is Nothing Then
MsgBox "User exists!"
If PwdTextBox.Text = UserMatch.Offset(0, 1) Then
MsgBox "Pwd matched!"
'do something
Else
MsgBox "Wrong password!"
'do something
End If
Else
MsgBox "User dont exists!"
'do something
End If
This will work if in the database the usernames are in column A and the passwords in column B.
I have the following code that loads a worksheet in full screen for 1 minute, and then moves onto the next worksheet in the workbook, using the exactly the same methodology.
This is to show stats on a big screen, looping through several stats pages.
This works perfectly on Excel 2007 and 2010.
Yet when the same code is executed on Excel 2013, Excel simply maxes out 1 core of my CPU and stays at not responding. I cannot even Escape to break the code execution. Stepping through the code line by line works fine on all versions.
'Loads up Daily Dispatch Figures worksheet
Application.ScreenUpdating = False
Sheets("Daily Dispatch Figures").Select
Range("A1").Select
Range("A1:C36").Select
ActiveWindow.Zoom = True
Range("A1").Select
ActiveWindow.DisplayHeadings = False
Application.DisplayFormulaBar = False
Application.DisplayFullScreen = True
Application.ScreenUpdating = True
' Stays on this screen for 1 min
TimVal = Now + TimeValue("0:01:00")
Do Until Now >= TimVal
Loop
Ooo, don't do this:
' Stays on this screen for 1 min
TimVal = Now + TimeValue("0:01:00")
Do Until Now >= TimVal
Loop
Try this:
Application.OnTime Now + TimeValue("0:01:00"), "ProcedureToRun"
You don't want to catch your application in an infinite loop with no sleeps.
Any time you sit in an infinite loop without sleeping, it will use 100% of your Processor time doing nothing. Application.OnTime "schedules" an event and returns control to the Excel UI Thread instead of infinitely looping.
You can read more here: https://msdn.microsoft.com/en-us/library/office/ff196165.aspx
I'm not sure what you're doing after your loop, but you need to make sure you have the code in a separate subroutine and call it.
Here is a Subroutine to go to the next sheet.
Sub MoveNext()
On Error Resume Next
Sheets(ActiveSheet.Index + 1).Activate
If Err.Number <> 0 Then Sheets(1).Activate
On Error Goto 0
End Sub
You can add the Application.OnTime to the end of it and have it call itself:
Sub MoveNext()
On Error Resume Next
Sheets(ActiveSheet.Index + 1).Activate
If Err.Number <> 0 Then Sheets(1).Activate
On Error Goto 0
Application.OnTime Now + TimeValue("00:01:00"), MoveNext
End Sub
This way it will loop and go from sheet to sheet forever (or until you stop it in whatever method you choose to use).
Finally, you can cancel this by storing the scheduled time and using Scheduled:=False.
Your final code could look something like this:
Public scheduledTime as Date
Sub StartDisplaying()
'Your start code:
'---------------------------------------------
Application.ScreenUpdating = False
Sheets("Daily Dispatch Figures").Select
Range("A1").Select
Range("A1:C36").Select
ActiveWindow.Zoom = True
Range("A1").Select
ActiveWindow.DisplayHeadings = False
Application.DisplayFormulaBar = False
Application.DisplayFullScreen = True
Application.ScreenUpdating = True
'---------------------------------------------
scheduledTime = Now + TimeValue("00:01:00")
Application.OnTime scheduledTime, MoveNext
End Sub
Sub StopDisplaying()
'Your stop code:
'---------------------------------------------
Application.ScreenUpdating = False
Sheets("Daily Dispatch Figures").Select
ActiveWindow.Zoom = False
ActiveWindow.DisplayHeadings = True
Application.DisplayFormulaBar = True
Application.DisplayFullScreen = False
Application.ScreenUpdating = True
'---------------------------------------------
Application.OnTime EarliestTime:=scheduledTime, Procedure:="MoveNext", Schedule:=False
End Sub
Sub MoveNext()
On Error Resume Next
Sheets(ActiveSheet.Index + 1).Activate
If Err.Number <> 0 Then Sheets(1).Activate
On Error Goto 0
scheduledTime = Now + TimeValue("00:01:00")
Application.OnTime scheduledTime, MoveNext
End Sub
I created one button and after my workbook loads, I want my button to appear after 10 seconds (not right away).
Dim ButtonOneClick As Boolean
Sub Button3_Click()
Sub disenable()
Dim b1 As Button
Set b1 = Sheets("Sheet2").Button3_Click()
Sheets("Sheet2").Button3_Click.Enabled = False
DoEvents
Application.ScreenUpdating = True
For i = 1 To 10
Application.Wait (Now + TimeValue("0:00:1"))
Next i
'Sheets(1).button1.Enabled = False
End Sub
Try this on activating the sheet or adjust to your needs
Private Sub Worksheet_Activate()
Me.Buttons("Button 1").Visible = False
Application.ScreenUpdating = True
Application.Wait (Now + #12:00:10 AM#)
Me.Buttons("Button 1").Visible = True
End Sub