Posts by blue

blue · Jun 14th 2006

Re: Splash Screen Errors

Thanks so much Roy. I have something else I have to attend to this morning but will get it incorportated back into my project later today (I hope). Thanks so very much for your help!

blue · Jun 14th 2006

Re: Splash Screen Errors

I agree that there are probably more important things to tackle than a Splash Screen but I have designed and slaved over our company sales and engineering workbook for about 7 years. It does a superlative job and it has been a struggle since I am an Engineer, not a Programmer. That said, my boss wants it to have a very polished look, hence the time spent on the Splash Screen.

I have attached the screen and code.

Thank you for your help!

blue · Jun 13th 2006

Re: Device I/O Error

Actually I had pulled a bas module into my spreadsheet when it wasn't required to produce the splash screen. Once I removed that module, the "Device I/O" error went away.

Thanks...

blue · Jun 13th 2006

Re: Splash Screen Errors

That is the code (your reference, Dave) I used to use and, although it worked, wasn't as professional looking as I would have liked. I found an example that has the splash screen fade in and out (per the above code). I just can't get it to remove itself no matter how many "Unload Me"'s I put in there.

That's the help I was requesting.

blue · Jun 13th 2006

Well, here I am again. One problem resolved but others keep cropping up. I am trying to display a splash screen which fades in and then fades out and closes itself leaving the ap showing. I have utilized code that I found wih permission to use but I'm still doing something wrong.

Code

Option Explicit
'// This Userform code has everything you need to make a captionless userform
'// Fade In & Out


'// Transparency
Private Declare Function SetLayeredWindowAttributes _
    Lib "user32" ( _
        ByVal hWnd As Long, _
        ByVal crKey As Long, _
        ByVal bAlpha As Byte, _
        ByVal dwFlags As Long) _
As Long


'// Title Bar
Private Declare Function GetWindowRect _
    Lib "user32" ( _
        ByVal hWnd As Long, _
        lpRect As RECT) _
As Long
   
Private Declare Function SetWindowLong _
    Lib "user32" _
        Alias "SetWindowLongA" ( _
            ByVal hWnd As Long, _
            ByVal nIndex As Long, _
            ByVal dwNewLong As Long) _
As Long


Private Declare Function GetWindowLong _
    Lib "user32" _
        Alias "GetWindowLongA" ( _
            ByVal hWnd As Long, _
            ByVal nIndex As Long) _
As Long
   
'// Win Styles
Private Const GWL_EXSTYLE = (-20)
Private Const GWL_STYLE = (-16)


Private Const WS_EX_LAYERED = &H80000
Private Const WS_CAPTION = &HC00000            ' WS_BORDER Or WS_DLGFRAME
Private Const WS_MAXIMIZEBOX = &H10000
Private Const WS_MINIMIZEBOX = &H20000
Private Const WS_SYSMENU = &H80000


'// Trans
Private Const LWA_COLORKEY = &H1
Private Const LWA_ALPHA = &H2
Private Const ULW_COLORKEY = &H1
Private Const ULW_ALPHA = &H2
Private Const ULW_OPAQUE = &H4


'// Used for moving Captionless form
Private Declare Function SetWindowPos _
    Lib "user32" ( _
        ByVal hWnd As Long, _
        ByVal hWndInsertAfter As Long, _
        ByVal X As Long, _
        ByVal Y As Long, _
        ByVal cx As Long, _
        ByVal cy As Long, _
        ByVal wFlags As Long) _
As Long


Private Declare Function SendMessage _
    Lib "user32" _
        Alias "SendMessageA" ( _
            ByVal hWnd As Long, _
            ByVal wMsg As Long, _
            ByVal wParam As Long, _
            lParam As Any) _
As Long


 
Private Declare Function FindWindowA _
    Lib "user32" ( _
        ByVal lpClassName As String, _
        ByVal lpWindowName As String) _
As Long
  
Private Const SWP_SHOWWINDOW = &H40
Private Const SWP_HIDEWINDOW = &H80
Private Const SWP_FRAMECHANGED = &H20 ' The frame changed: send WM_NCCALCSIZE
Private Const SWP_NOACTIVATE = &H10
Private Const SWP_NOCOPYBITS = &H100
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOOWNERZORDER = &H200    ' Don't do owner Z ordering
Private Const SWP_NOREDRAW = &H8
Private Const SWP_NOREPOSITION = SWP_NOOWNERZORDER
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOZORDER = &H4
Private Const SWP_DRAWFRAME = SWP_FRAMECHANGED
Private Const HWND_NOTOPMOST = -2


Private Type RECT
    Left   As Long
    Top    As Long
    Right  As Long
    Bottom As Long
End Type


Private lResult As Long
Private frmHdl As Long
Private blnTitleVisible As Boolean
Private blnCtrlShow As Boolean


Private lFrmHdl  As Long


Private Sub Label1_Click()


End Sub


''
Private Sub UserForm_Activate()
Application.Visible = False


'// Main routines


    Application.Wait (Now + TimeValue("0:00:02"))
    Call FadeOut(256 * 4)
    Application.Wait (Now + TimeValue("0:00:01"))
    Call FadeIn(256 * 4)
    Application.Wait (Now + TimeValue("0:00:20"))


Application.Visible = True
End Sub


Private Sub UserForm_Initialize()
    '// Ivan F Moala
    lFrmHdl = FindWindowA(vbNullString, Me.Caption)
    ShowTitleBar False
    '// Need this call 1st to set > No Flicker
    MakeTransparent (255)
    KillTheForm
End Sub


'// MODIFIED: Ivan F Moala 2/6/2002
Private Sub UserForm_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    '// Leave this here as your backdoor, incase you have NO CLOSE BUTTON
    Unload Me
    Application.Visible = True
End Sub




'// Handles the Userform Title
Private Function ShowTitleBar(ByVal bState As Boolean)
Dim lStyle As Long
Dim tR As RECT


'// Get the window's position:
GetWindowRect lFrmHdl, tR


'// Modify whether title bar will be visible:
lStyle = GetWindowLong(lFrmHdl, GWL_STYLE)
    '
 If Not bState Then
    lStyle = lStyle And Not WS_SYSMENU
    lStyle = lStyle And Not WS_MAXIMIZEBOX
    lStyle = lStyle And Not WS_MINIMIZEBOX
    lStyle = lStyle And Not WS_CAPTION
    blnTitleVisible = True
Else
    lStyle = lStyle Or WS_SYSMENU
    lStyle = lStyle Or WS_MAXIMIZEBOX
    lStyle = lStyle Or WS_MINIMIZEBOX
    lStyle = lStyle Or WS_CAPTION
    blnTitleVisible = False
End If


SetWindowLong lFrmHdl, GWL_STYLE, lStyle


'// Ensure the style takes and make the window the
'// same size, regardless that the title bar
'// is now a different size:
SetWindowPos lFrmHdl, 0, tR.Left, tR.Top, tR.Right - tR.Left, tR.Bottom - tR.Top, _
    SWP_NOREPOSITION Or SWP_NOZORDER Or SWP_FRAMECHANGED
'Me.Repaint


End Function


'// Transparency routines
Private Sub FadeIn(Fin As Long)
Dim X As Long


X = 0
Do Until X = Fin
    DoEvents
    X = X + 1
    MakeTransparent X / 2
Loop


End Sub


Private Function FadeOut(Fin As Long)
Dim Y As Long
    
Y = Fin
    
Do Until Y = 0
    DoEvents
    Y = Y - 1
    Call MakeTransparent(Y / 2)
Loop


End Function


Private Function MakeTransparent(lIndex As Long) As Long


On Error Resume Next
If lIndex < 0 Or lIndex > 255 Then
    MakeTransparent = 0 '1
Else
    lResult = GetWindowLong(lFrmHdl, GWL_EXSTYLE)
    lResult = lResult Or WS_EX_LAYERED
    SetWindowLong lFrmHdl, GWL_EXSTYLE, lResult
    SetLayeredWindowAttributes lFrmHdl, 0, lIndex, LWA_ALPHA
    MakeTransparent = 0
End If


If Err Then MakeTransparent = 2


End Function


Private Sub KillTheForm()
    Unload SplashScreen
End Sub

Display More

Could someone please give me a hand!

Thanks much!

blue · Jun 12th 2006

Re: Device I/O Error

I found the problem with the I/O Error. Thanks to anyone who took the time to read my thread.

blue · Jun 12th 2006

I just recently cut and pasted the code found at http://www.xcelfiles.com/Tips01.html for presenting a splash screen. I don't think that there should have been any reason for the code to suddently create the I/O Error. The splash screen works well, then reproduces itself and if I click any sheet in my spreadsheet I get "Device I/O Error". I looked back at other reports of this error but they didn't seem to help. So perhaps someone else has had this problem. I appreciate any help I can get. If necessary, I will certainly post the code.

I can't step through the code either - I just get the same error.

Thanks so much in advance!

blue · Jun 8th 2006

Re: hiding the "X" or close button on user form

Thanks so much for your response. Yes, I agree that the code needs to be modified so that there is no error with a normal close using the "X" however this is a huge workbook with a lot of code. I have no idea how to start looking for the problem. I know just enough to make me truly dangerous! LOL

Thanks much!

blue · Jun 7th 2006

Re: hiding the "X" or close button on user form

Hi all,

I need to "grey" out the exit button on a workbook that is shared with others. Using the "X" button at the top right hand corner results in errors. Exiting via a command button that I have added to the toolbars lets the Excel environment be reinstated and exits this workbook gracefully.

I have added the Sub Userform_QueryClose and it does not seem to be doing the job. In testing, I was still able to close the workbook via the "X" at the top. What might I be overlooking?

Thanks much!

blue · Jan 25th 2006

Re: Intersect Method with Worksheet_Change

Ever so grateful, Bob!

blue · Jan 25th 2006

Re: Intersect Method with Worksheet_Change

Of course! Once again I just didn't think about that...

Thanks much!

blue · Jan 24th 2006

Re: Intersect Method with Worksheet_Change

The workbook is much larger than 45 KB. How do I handle that kind of upload?

blue · Jan 24th 2006

Re: Intersect Method with Worksheet_Change

Ok, all is working with the exception of range 6 which hangs up just before the paste special and I have checked it and checked it again and again and can't find anything different from the preceeding code. Here it is in it's new entirety thanks to you guys. Now just the final error and I will leave you all alone for a while with great appreciation!

Code

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Range1 As Range
    Dim Range2 As Range
    Dim Range3 As Range
    Dim Range4 As Range
    Dim Range5 As Range
    Dim Range6 As Range
     
    On Error GoTo ws_exit
    Application.EnableEvents = False
     
    Set Range1 = Range("J3:J16")
    Set Range2 = Range("T3:T16")
    Set Range3 = Range("J20:J32")
    Set Range4 = Range("T20:T32")
    Set Range5 = Range("J36:J50")
    Set Range6 = Range("T36:T50")
     
   If Not Intersect(Range1, Target) Is Nothing Then
        Application.EnableEvents = False
        Range("A" & Target.Row).Resize(, 10).ClearContents
        Range("A" & Target.Row + 1 & ":I16").Copy
        Range("A" & Target.Row & ":I15").PasteSpecial xlPasteValues
        Range("A16:I16").ClearContents
        Range("A3").Select
        Application.EnableEvents = True
    End If
    
    If Not Intersect(Range2, Target) Is Nothing Then
        Application.EnableEvents = False
        Range("K" & Target.Row).Resize(, 10).ClearContents
        Range("K" & Target.Row + 1 & ":S16").Copy
        Range("K" & Target.Row & ":S15").PasteSpecial xlPasteValues
        Range("K16:T16").ClearContents
        Range("K3").Select
        Application.EnableEvents = True
    End If
    
    If Not Intersect(Range3, Target) Is Nothing Then
        Application.EnableEvents = False
        Range("A" & Target.Row).Resize(, 10).ClearContents
        Range("A" & Target.Row + 1 & ":I32").Copy
        Range("A" & Target.Row & ":I31").PasteSpecial xlPasteValues
        Range("A32:J32").ClearContents
        Range("A20").Select
        Application.EnableEvents = True
    End If
    
    If Not Intersect(Range4, Target) Is Nothing Then
        Application.EnableEvents = False
        Range("K" & Target.Row).Resize(, 10).ClearContents
        Range("K" & Target.Row + 1 & ":S32").Copy
        Range("K" & Target.Row & ":S31").PasteSpecial xlPasteValues
        Range("K32:T32").ClearContents
        Range("K20").Select
        Application.EnableEvents = True
    End If


    If Not Intersect(Range5, Target) Is Nothing Then
        Application.EnableEvents = False
        Range("A" & Target.Row).Resize(, 10).ClearContents
        Range("A" & Target.Row + 1 & ":I50").Copy
        Range("A" & Target.Row & ":I49").PasteSpecial xlPasteValues
        Range("A50:J50").ClearContents
        Range("A36").Select
        Application.EnableEvents = True
    End If
    
    If Not Intersect(Range6, Target) Is Nothing Then
        Application.EnableEvents = False
        Range("K" & Target.Row).Resize(, 10).ClearContents
        Range("K" & Target.Row + 1 & ":S50").Copy
        Range("K" & Target.Row & ":S49").PasteSpecial xlPasteValues
        Range("K50:T50").ClearContents
        Range("K36").Select
        Application.EnableEvents = True
    End If






     
ws_exit:
    Application.EnableEvents = True
End Sub

Display More

blue · Jan 24th 2006

Re: Intersect Method with Worksheet_Change

That did it! Thanks so much to the both of you! Now I think I can carry this on following the logic and complete the assignment. Bless you all!

blue · Jan 24th 2006

Re: Intersect Method with Worksheet_Change

Ok, figured out one thing that was wrong. Somewhere along the line

Code

application.enableevents = true

did not happen. When I manually added that, at least something happened. The row I wanted cleared was cleared but the subsequent rows did not move up one row so now I have the worksheet with a blank row in the middle of the range.

blue · Jan 24th 2006

Re: Intersect Method with Worksheet_Change

I commented out all my code, cut and pasted yours in and nothing is happening. I don't get any errors but nothing happens on my worksheet either.

Thanks so much for your help!

blue · Jan 24th 2006

Re: Intersect Method with Worksheet_Change

Exactly! So I wonder what's up with that? Did you have the

Code

If Target.Count>1 Then Exit Sub

included when you ran it? I guess that doesn't make any difference since I just commented that out and now it doesn't run at all.

I just have no idea what is going on right now. I have the following:

Code

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Range1 As Range
Dim Range2 As Range
Dim Range3 As Range
Dim Range4 As Range
Dim Range5 As Range
Dim Range6 As Range
Dim IntersectRange1 As Range
Dim IntersectRange2 As Range
Dim IntersectRange3 As Range
Dim IntersectRange4 As Range
Dim IntersectRange5 As Range
Dim IntersectRange6 As Range




Set Range1 = Range("J3:J16")
Set Range2 = Range("T3:T16")
Set Range3 = Range("J20:J32")
Set Range4 = Range("T20:T32")
Set Range5 = Range("J36:J50")
Set Range6 = Range("T36:T50")


Set IntersectRange1 = Intersect(Target, Range1)
Set IntersectRange2 = Intersect(Target, Range2)
Set IntersectRange3 = Intersect(Target, Range3)
Set IntersectRange4 = Intersect(Target, Range4)
Set IntersectRange5 = Intersect(Target, Range5)
Set IntersectRange6 = Intersect(Target, Range6)


If IntersectRange1 Is Nothing Then Exit Sub 'For debug purposes only
If Target.Count > 1 Then Exit Sub


    Application.ScreenUpdating = False
    Application.EnableEvents = False
     
    lRow = IntersectRange1.Row
    Range("A" & lRow & ":J" & lRow).ClearContents
    Range("A" & lRow + 1 & ":I16").Copy
    Range("A" & lRow & ":I15").PasteSpecial xlPasteValues
    Range("A16:I16").ClearContents
     
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Display More

And nothing is happening. I cut and pasted your code and made no changes except for the typo. I'm confused (to say the least).

Thanks,

blue · Jan 24th 2006

Re: Intersect Method with Worksheet_Change

Sure, I'll cut and paste the first portion and upload it.

Hope this works and thanks a million!

blue · Jan 24th 2006

Re: Intersect Method with Worksheet_Change

Gee, Norie, you think I could have spotted that for myself! Duh! Anyway, by adding the

Code

If Target.Count>1 Then Exit Sub

the macro exits even though I am adding an "x" in only one of the intersect cells so it must be looping somewhere even with the

Code

Application.EnableEvents = False

statement.

Thanks so much for your help!

blue · Jan 24th 2006

Re: Intersect Method with Worksheet_Change

Yes, I just did, Norie and I got a type mismatch at line:

Code

Range("A" * lRow & ":I15").PasteSpecial xlPasteValues

Thanks,

Sue