INTELLIGENT WORK FORUMS
FOR COMPUTER PROFESSIONALS

Log In

Come Join Us!

Are you a
Computer / IT professional?
Join Tek-Tips Forums!
  • Talk With Other Members
  • Be Notified Of Responses
    To Your Posts
  • Keyword Search
  • One-Click Access To Your
    Favorite Forums
  • Automated Signatures
    On Your Posts
  • Best Of All, It's Free!

*Tek-Tips's functionality depends on members receiving e-mail. By joining you are opting in to receive e-mail.

Posting Guidelines

Promoting, selling, recruiting, coursework and thesis posting is forbidden.

Jobs

Compile Error Automation Type Not Supported In Visual Basic

Compile Error Automation Type Not Supported In Visual Basic

(OP)
I need help from someone with good VB/VBA knowledge to help edit/convert this code so that it compiles, is compatible and works in Access 2003. It fails to compile on the highlighted line?

CODE -->

Option Compare Database
Option Explicit
    
    Private Type CWPSTRUCT
        lParam As Long
        wParam As Long
        message As Long
        hwnd As Long
    End Type
    
    'Added by manavo11
    Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
    End Type
    
    Private Type LOGBRUSH
        lbStyle As Long
        lbColor As Long
        lbHatch As Long
    End Type
    'Added by manavo11
    
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
    Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long
    Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) 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 CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam 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 GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    
    'Added by manavo11
    Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
    Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
    Private Declare Function CreateBrushIndirect Lib "gdi32" (lpLogBrush As LOGBRUSH) As Long
    Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
    
    Private Declare Function SetFocus Lib "user32" (ByVal hwnd As Long) As Long
    
    Private Declare Function MoveWindow Lib "user32" (ByVal hwnd As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
    Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
    'Added by manavo11
    
    Private Const WH_CALLWNDPROC = 4
    Private Const GWL_WNDPROC = (-4)
    Private Const WM_CTLCOLORBTN = &H135
    Private Const WM_DESTROY = &H2
    Private Const WM_SETTEXT = &HC
    Private Const WM_CREATE = &H1
    
    'Added by manavo11
    ' System Color Constants
    Private Const COLOR_BTNFACE = 15
    Private Const COLOR_BTNTEXT = 18
    
    ' Windows Messages
    Private Const WM_CTLCOLORSTATIC = &H138
    Private Const WM_CTLCOLORDLG = &H136
    
    Private Const WM_SHOWWINDOW As Long = &H18
    'Added by manavo11
    
    Private lHook As Long
    Private lPrevWnd As Long
    
    Private bCustom As Boolean
    Private sButtons() As String
    Private lButton As Long
    Private sHwnd As String
    
    'Added by manavo11
    Private lForecolor As Long
    Private lBackcolor As Long
    
    Private sDefaultButton As String
    
    Private iX As String
    Private iY As String
    Private iWidth As String
    Private iHeight As String
    
    Private iButtonCount As Integer
    Private iButtonWidth As Integer
    'Added by manavo11
    
    Public Function SubMsgBox(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
        Dim sText As String
      
        Select Case Msg
      
        'Added by manavo11
        Case WM_SHOWWINDOW
            Dim MsgBoxRect As RECT
          
            GetWindowRect hwnd, MsgBoxRect
          
            If StrPtr(iX) = 0 Then
                iX = MsgBoxRect.Left
            End If
          
            If StrPtr(iY) = 0 Then
                iY = MsgBoxRect.Top
            End If
          
            If StrPtr(iWidth) = 0 Then
                iWidth = MsgBoxRect.Right - MsgBoxRect.Left
            Else
                Dim i As Integer
                Dim h As Long
              
                Dim ButtonRECT As RECT
              
                For i = 0 To iButtonCount
                    h = FindWindowEx(hwnd, h, "Button", vbNullString)
                  
                    GetWindowRect h, ButtonRECT
                  
                    MoveWindow h, 14 + (iButtonWidth * i) + (6 * i), iHeight - (ButtonRECT.Bottom - ButtonRECT.Top) - 40, iButtonWidth, ButtonRECT.Bottom - ButtonRECT.Top, 1
                Next
            End If
          
            If StrPtr(iHeight) = 0 Then
                iHeight = MsgBoxRect.Bottom - MsgBoxRect.Top
            End If
          
            MoveWindow hwnd, iX, iY, iWidth, iHeight, 1
        Case WM_CTLCOLORDLG, WM_CTLCOLORSTATIC
            Dim tLB As LOGBRUSH
            'Debug.Print wParam
          
            Call SetTextColor(wParam, lForecolor)
            Call SetBkColor(wParam, lBackcolor)
          
            tLB.lbColor = lBackcolor
          
            SubMsgBox = CreateBrushIndirect(tLB)
            Exit Function
        'Added by manavo11
      
        Case WM_CTLCOLORBTN
            'Customize the MessageBox Buttons if neccessary..
            'First Process the Default Action of the Message (Draw the Button)
            SubMsgBox = CallWindowProc(lPrevWnd, hwnd, Msg, wParam, ByVal lParam)
            'Now Change the Button Text if Required
            If Not bCustom Then Exit Function
            If lButton = 0 Then sHwnd = ""
            'If this Button has Been Modified Already then Exit
            If InStr(sHwnd, " " & Trim(Str(lParam)) & " ") Then Exit Function
            sText = sButtons(lButton)
            sHwnd = sHwnd & " " & Trim(Str(lParam)) & " "
            lButton = lButton + 1
            'Modify the Button Text
            SendMessage lParam, WM_SETTEXT, Len(sText), ByVal sText
          
            'Added by manavo11
            If sText = sDefaultButton Then
                SetFocus lParam
            End If
            'Added by manavo11
          
            Exit Function
          
        Case WM_DESTROY
            'Remove the MsgBox Subclassing
            Call SetWindowLong(hwnd, GWL_WNDPROC, lPrevWnd)
        End Select
        SubMsgBox = CallWindowProc(lPrevWnd, hwnd, Msg, wParam, ByVal lParam)
    End Function
    
    Private Function HookWindow(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
        Dim tCWP As CWPSTRUCT
        Dim sClass As String
        'This is where you need to Hook the Messagebox
        CopyMemory tCWP, ByVal lParam, Len(tCWP)
        If tCWP.message = WM_CREATE Then
            sClass = Space(255)
            sClass = Left(sClass, GetClassName(tCWP.hwnd, ByVal sClass, 255))
            If sClass = "#32770" Then
                'Subclass the Messagebox as it's created
                lPrevWnd = SetWindowLong(tCWP.hwnd, GWL_WNDPROC, AddressOf SubMsgBox)
            End If
        End If
        HookWindow = CallNextHookEx(lHook, nCode, wParam, ByVal lParam)
    End Function
    
    Public Function MsgBoxEx(ByVal Prompt As String, Optional ByVal Buttons As Long = vbOKOnly, Optional ByVal Title As String, Optional ByVal HelpFile As String, Optional ByVal Context As Long, Optional ByRef CustomButtons As Variant, Optional DefaultButton As String, Optional X As String, Optional Y As String, Optional Width As String, Optional Height As String, Optional ByVal ForeColor As ColorConstants = -1, Optional ByVal BackColor As ColorConstants = -1) As Long
        Dim lReturn As Long
      
        bCustom = (Buttons = vbCustom)
        If bCustom And IsMissing(CustomButtons) Then
            MsgBox "When using the Custom option you need to supply some Buttons in the ""CustomButtons"" Argument.", vbExclamation + vbOKOnly, "Error"
            Exit Function
        End If
        lHook = SetWindowsHookEx(WH_CALLWNDPROC, AddressOf HookWindow, App.hInstance, App.ThreadID)
        'Set the Defaults
        If Len(Title) = 0 Then Title = App.Title
        If bCustom Then
            'User wants to use own Button Titles..
            If TypeName(CustomButtons) = "String" Then
                ReDim sButtons(0)
                sButtons(0) = CustomButtons
                Buttons = 0
            Else
                sButtons = CustomButtons
                Buttons = UBound(sButtons)
            End If
        End If
      
        'Added by manavo11
        lForecolor = GetSysColor(COLOR_BTNTEXT)
        lBackcolor = GetSysColor(COLOR_BTNFACE)
      
        If ForeColor >= 0 Then lForecolor = ForeColor
        If BackColor >= 0 Then lBackcolor = BackColor
      
        sDefaultButton = DefaultButton
      
        iX = X
        iY = Y
        iWidth = Width
        iHeight = Height
      
        iButtonCount = UBound(sButtons)
        iButtonWidth = (iWidth - (2 * 14) - (6 * (Buttons + 1))) / (Buttons + 1)
        'Added by manavo11
      
        lButton = 0
      
        'Show the Modified MsgBox
        lReturn = MsgBox(Prompt, Buttons, Title, HelpFile, Context)
        Call UnhookWindowsHookEx(lHook)
        'If it's a Custom Button MsgBox, Alter the Return Value
        If bCustom Then lReturn = lReturn - (UBound(CustomButtons) + 1)
        bCustom = False
        MsgBoxEx = lReturn
    End Function

    Sub test()
        Dim aButtons(2) As String
        aButtons(0) = "Go"
        aButtons(1) = "Come"
        aButtons(2) = "???"
    
        Caption = aButtons(MsgBoxEx("Text" & vbCrLf & "More Text" & vbCrLf & "Even More Text", vbCustom, "Title", , , aButtons, aButtons(1), 0, 0, 200, 300, vbWhite, vbBlue))
    End Sub 

RE: Compile Error Automation Type Not Supported In Visual Basic

From Optional Parameters (Visual Basic):

"Every optional parameter in the procedure definition must specify a default value"

So you may try:

CODE

Public Function MsgBoxEx( _
ByVal Prompt As String, _
Optional ByVal Buttons As Long = vbOKOnly, _
Optional ByVal Title As String = "", _
Optional ByVal HelpFile As String = "", _
Optional ByVal Context As Long = 0, _
Optional ByRef CustomButtons As Variant = "", _
Optional DefaultButton As String = "", _
Optional X As String = "", _
Optional Y As String = "", _
Optional Width As String = "", _
Optional Height As String = "", _
Optional ByVal ForeColor As ColorConstants = -1, _
Optional ByVal BackColor As ColorConstants = -1) As Long 

Have fun.

---- Andy

There is a great need for a sarcasm font.

RE: Compile Error Automation Type Not Supported In Visual Basic

That's only the case for VB.NET, Andy, not for VBA,which is what Patricia is using; VBA happily provides its own defaults if you do not.

RE: Compile Error Automation Type Not Supported In Visual Basic

(OP)
So if Andy was not on the right tracks and the defaults are provided by VBA with the code the way it is what must I change for it to work?

RE: Compile Error Automation Type Not Supported In Visual Basic

Sorry sad
Don't you just hate when web pages do not state if the info is for VB6, VBA, VB.NET, or whatever... (unless I have missed it, on the second look - yes, I missed it)

I would start by eliminating substituting (or testing on the side) some of the arguments from your Function, like:

CODE

Optional ByVal ForeColor As ColorConstants = -1, _
Optional ByVal BackColor As ColorConstants = -1) 


Have fun.

---- Andy

There is a great need for a sarcasm font.

RE: Compile Error Automation Type Not Supported In Visual Basic

ColorConstants is the primary problem

RE: Compile Error Automation Type Not Supported In Visual Basic

Your code fails in Optional ByVal ForeColor As ColorConstants = -1, VBA does not accept this type. Make it Long instead.

combo

RE: Compile Error Automation Type Not Supported In Visual Basic

(OP)
Thank you for that I changed forecolor and backcolor to Long but it then fails on vbCustom and then on App.hInstance.

I think it needs someone who knows how (and is willing) to change all the necessary vb code to vba.

If there’s anyone here who will do that I would be very interested in seeing how it looks.

RE: Compile Error Automation Type Not Supported In Visual Basic

No vbCustom constnt in VBA. What is App? If access, no ThreadID and hInstance properties. Verify in Object Browser.

combo

RE: Compile Error Automation Type Not Supported In Visual Basic

(OP)
Hi combo

Yes, that's why this code needs converting to vba the best way it can to work with Access 2003.

For that we need someone with knowledge of vb and vba.

RE: Compile Error Automation Type Not Supported In Visual Basic

Object Browser is your close friend.

combo

RE: Compile Error Automation Type Not Supported In Visual Basic

(OP)
Thank you combo, but I'm way out of my depth here, my programming language is HTML.

RE: Compile Error Automation Type Not Supported In Visual Basic

As I said, ColorConstants is only the primary issue. There's really quite a lot of donkey work to do here to get it working in VBA.

RE: Compile Error Automation Type Not Supported In Visual Basic

(OP)
Hi strongm, thank you for your reply and I do understand if you can't help me but my HTML programming skills are simply not up to the task so if you can find your way to helping out them thank you it would be very much appreciated, and if not then like I said I do understand.

RE: Compile Error Automation Type Not Supported In Visual Basic

It looks to me the 2 last parameters set the Fore color and Back color of the font in the custom message box. You may consider removing this ability. Frankly I don't see any reason to mess with the default color's settings, but that's your call.

Have fun.

---- Andy

There is a great need for a sarcasm font.

RE: Compile Error Automation Type Not Supported In Visual Basic

That's not the issue, Andy. Combo has already provided a fix to that.

RE: Compile Error Automation Type Not Supported In Visual Basic

CODE

Option Compare Database
Option Explicit
    
    Private Type CWPSTRUCT
        lParam As Long
        wParam As Long
        message As Long
        hwnd As Long
    End Type
    
    'Added by manavo11
    Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
    End Type
    
    Private Type LOGBRUSH
        lbStyle As Long
        lbColor As Long
        lbHatch As Long
    End Type
    'Added by manavo11
    
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
    Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long
    Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) 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 CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam 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 GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    
    'Added by manavo11
    Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
    Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
    Private Declare Function CreateBrushIndirect Lib "gdi32" (lpLogBrush As LOGBRUSH) As Long
    Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
    
    Private Declare Function SetFocus Lib "user32" (ByVal hwnd As Long) As Long
    
    Private Declare Function MoveWindow Lib "user32" (ByVal hwnd As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
    Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
    
    Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As Any) As Long
    Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
    
    'Added by manavo11
    
    Private Const WH_CALLWNDPROC = 4
    Private Const GWL_WNDPROC = (-4)
    Private Const WM_CTLCOLORBTN = &H135
    Private Const WM_DESTROY = &H2
    Private Const WM_SETTEXT = &HC
    Private Const WM_CREATE = &H1
    
    'Added by manavo11
    ' System Color Constants
    Private Const COLOR_BTNFACE = 15
    Private Const COLOR_BTNTEXT = 18
    
    ' Windows Messages
    Private Const WM_CTLCOLORSTATIC = &H138
    Private Const WM_CTLCOLORDLG = &H136
    
    Private Const WM_SHOWWINDOW As Long = &H18
    'Added by manavo11
    
    Private Const vbCustom = 99
    
    Private lHook As Long
    Private lPrevWnd As Long
    
    Private bCustom As Boolean
    Private sButtons() As String
    Private lButton As Long
    Private sHwnd As String
    
    'Added by manavo11
    Private lForecolor As Long
    Private lBackcolor As Long
    
    Private sDefaultButton As String
    
    Private iX As String
    Private iY As String
    Private iWidth As String
    Private iHeight As String
    
    Private iButtonCount As Integer
    Private iButtonWidth As Integer
    'Added by manavo11
    
    Public Function SubMsgBox(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
        Dim sText As String
      
        Select Case Msg
      
        'Added by manavo11
        Case WM_SHOWWINDOW
            Dim MsgBoxRect As RECT
          
            GetWindowRect hwnd, MsgBoxRect
          
            If StrPtr(iX) = 0 Then
                iX = MsgBoxRect.Left
            End If
          
            If StrPtr(iY) = 0 Then
                iY = MsgBoxRect.Top
            End If
          
            If StrPtr(iWidth) = 0 Then
                iWidth = MsgBoxRect.Right - MsgBoxRect.Left
            Else
                Dim i As Integer
                Dim h As Long
              
                Dim ButtonRECT As RECT
              
                For i = 0 To iButtonCount
                    h = FindWindowEx(hwnd, h, "Button", vbNullString)
                  
                    GetWindowRect h, ButtonRECT
                  
                    MoveWindow h, 14 + (iButtonWidth * i) + (6 * i), iHeight - (ButtonRECT.Bottom - ButtonRECT.Top) - 40, iButtonWidth, ButtonRECT.Bottom - ButtonRECT.Top, 1
                Next
            End If
          
            If StrPtr(iHeight) = 0 Then
                iHeight = MsgBoxRect.Bottom - MsgBoxRect.Top
            End If
          
            MoveWindow hwnd, iX, iY, iWidth, iHeight, 1
        Case WM_CTLCOLORDLG, WM_CTLCOLORSTATIC
            Dim tLB As LOGBRUSH
            'Debug.Print wParam
          
            Call SetTextColor(wParam, lForecolor)
            Call SetBkColor(wParam, lBackcolor)
          
            tLB.lbColor = lBackcolor
          
            SubMsgBox = CreateBrushIndirect(tLB)
            Exit Function
        'Added by manavo11
      
        Case WM_CTLCOLORBTN
            'Customize the MessageBox Buttons if neccessary..
            'First Process the Default Action of the Message (Draw the Button)
            SubMsgBox = CallWindowProc(lPrevWnd, hwnd, Msg, wParam, ByVal lParam)
            'Now Change the Button Text if Required
            If Not bCustom Then Exit Function
            If lButton = 0 Then sHwnd = ""
            'If this Button has Been Modified Already then Exit
            If InStr(sHwnd, " " & Trim(Str(lParam)) & " ") Then Exit Function
            sText = sButtons(lButton)
            sHwnd = sHwnd & " " & Trim(Str(lParam)) & " "
            lButton = lButton + 1
            'Modify the Button Text
            SendMessage lParam, WM_SETTEXT, Len(sText), ByVal sText
          
            'Added by manavo11
            If sText = sDefaultButton Then
                SetFocus lParam
            End If
            'Added by manavo11
          
            Exit Function
          
        Case WM_DESTROY
            'Remove the MsgBox Subclassing
            Call SetWindowLong(hwnd, GWL_WNDPROC, lPrevWnd)
        End Select
        SubMsgBox = CallWindowProc(lPrevWnd, hwnd, Msg, wParam, ByVal lParam)
    End Function
    
    Private Function HookWindow(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
        Dim tCWP As CWPSTRUCT
        Dim sClass As String
        'This is where you need to Hook the Messagebox
        CopyMemory tCWP, ByVal lParam, Len(tCWP)
        If tCWP.message = WM_CREATE Then
            sClass = Space(255)
            sClass = Left(sClass, GetClassName(tCWP.hwnd, ByVal sClass, 255))
            If sClass = "#32770" Then
                'Subclass the Messagebox as it's created
                lPrevWnd = SetWindowLong(tCWP.hwnd, GWL_WNDPROC, AddressOf SubMsgBox)
            End If
        End If
        HookWindow = CallNextHookEx(lHook, nCode, wParam, ByVal lParam)
    End Function
    
    Public Function MsgBoxEx(ByVal Prompt As String, Optional ByVal Buttons As Long = vbOKOnly, Optional ByVal Title As String, Optional ByVal HelpFile As String, Optional ByVal Context As Long, Optional ByRef CustomButtons As Variant, Optional DefaultButton As String, Optional X As String, Optional Y As String, Optional Width As String, Optional Height As String, Optional ByVal ForeColor As Long = -1, Optional ByVal BackColor As Long = -1) As Long
        Dim lReturn As Long
        Dim App As Application
        
        Set App = Application
      
        bCustom = (Buttons = vbCustom)
        If bCustom And IsMissing(CustomButtons) Then
            MsgBox "When using the Custom option you need to supply some Buttons in the ""CustomButtons"" Argument.", vbExclamation + vbOKOnly, "Error"
            Exit Function
        End If
        lHook = SetWindowsHookEx(WH_CALLWNDPROC, AddressOf HookWindow, GetModuleHandle(0&), GetCurrentThreadId())
        'Set the Defaults
        If Len(Title) = 0 Then Title = CurrentDb.Name
        If bCustom Then
            'User wants to use own Button Titles..
            If TypeName(CustomButtons) = "String" Then
                ReDim sButtons(0)
                sButtons(0) = CustomButtons
                Buttons = 0
            Else
                sButtons = CustomButtons
                Buttons = UBound(sButtons)
            End If
        End If
      
        'Added by manavo11
        lForecolor = GetSysColor(COLOR_BTNTEXT)
        lBackcolor = GetSysColor(COLOR_BTNFACE)
      
        If ForeColor >= 0 Then lForecolor = ForeColor
        If BackColor >= 0 Then lBackcolor = BackColor
      
        sDefaultButton = DefaultButton
      
        iX = X
        iY = Y
        iWidth = Width
        iHeight = Height
      
        iButtonCount = UBound(sButtons)
        iButtonWidth = (iWidth - (2 * 14) - (6 * (Buttons + 1))) / (Buttons + 1)
        'Added by manavo11
      
        lButton = 0
      
        'Show the Modified MsgBox
        lReturn = MsgBox(Prompt, Buttons, Title, HelpFile, Context)
        Call UnhookWindowsHookEx(lHook)
        'If it's a Custom Button MsgBox, Alter the Return Value
        If bCustom Then lReturn = lReturn - (UBound(CustomButtons) + 1)
        bCustom = False
        MsgBoxEx = lReturn
    End Function

    Sub test()
        Dim Caption As String
        Dim aButtons(2) As String
        aButtons(0) = "Go"
        aButtons(1) = "Come"
        aButtons(2) = "???"
        
        Caption = aButtons(MsgBoxEx("Text" & vbCrLf & "More Text" & vbCrLf & "Even More Text", vbCustom, "Title", , , aButtons, aButtons(1), 0, 0, 200, 300, vbWhite, vbBlue))
    End Sub 

RE: Compile Error Automation Type Not Supported In Visual Basic

I should point out however, that in my view if you want to customise a messagebox this heavily, you'd probably be safer using a userform designed to look like a messagebox. Unless you know what you are doing, messing about with windows hooks will almost certainly end up with you crashing your application (as I vaguely recall happened when we previously played with customised messageboxes a couple of years or so ago when you were a VBA programmer). I'd also comment that this code goes about things in a slightly convoluted way.

RE: Compile Error Automation Type Not Supported In Visual Basic

(OP)
Hi strongm, that was very generous of you and I thank you.
I hear your comments about hooking and a userform, I will have a go at creating a custom error message using a userform.
As for the code being slightly convoluted it will have to do because honestly it all seems slightly convoluted to me.
The custom messagebox code you refer to I have posted below and would like to know why the test sub at the end of the code doesn't seem to work for one button ie the vbOKOnly button, can this be fixed?

CODE -->

'Microsoft Access Modules (VBA Coding) - Wscript PopUp make application modal in MS Access
'http://www.tek-tips.com/viewthread.cfm?qid=1697437
Option Compare Database
Option Explicit

'Necessary constants for hooking.
Private Const HCBT_ACTIVATE = 5
Private Const WH_CBT = 5

'Possibly overkill for this example.
Private Type CUSTOM_MSGBOX
  lTimeout As Long
  lExitButton As Long
  lInterval As Long
  strPrompt As String
End Type

Private cm As CUSTOM_MSGBOX

'Working variables that require global scope in hooking module.
Private hHook As Long
Private hwndMsgBox As Long
Private lTimerHandle As Long
Private hAppInstance As Long

'The API declarations we need.
Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExW" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Const GWL_HINSTANCE = (-6)

'Windows-defined MessageBox return values.
Public Enum ExitButton
  idok = 1
  IDCANCEL = 2
  IDABORT = 3
  IDRETRY = 4
  IDIGNORE = 5
  IDYES = 6
  IDNO = 7
End Enum

'Timer handler stuff.
Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Private Declare Function SetFocus Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetDlgItem Lib "user32" (ByVal hDlg As Long, ByVal nIDDlgItem As Long) As Long
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function SetDlgItemText Lib "user32" Alias "SetDlgItemTextA" (ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal lpString As String) As Long

Private Const WM_LBUTTONDOWN = &H201
Private Const WM_LBUTTONUP = &H202
Private Const IDPROMPT = &HFFFF&

'Our wrapper for the normal MsgBox function.
Public Function vbTimedMsgBox(Prompt As String, Optional Buttons As VbMsgBoxStyle = vbOKOnly, Optional Title As String, Optional HelpFile As String, Optional Context As Long, Optional TimeOut As Long = 0, Optional Tick As Long = 1000, Optional DefaultExitButton As ExitButton = idok) As Long
cm.lTimeout = TimeOut
cm.lExitButton = DefaultExitButton
cm.strPrompt = Prompt
cm.lInterval = Tick

hAppInstance = GetWindowLong(hWndAccessApp, GWL_HINSTANCE) 'Access specific. In VB, this would be App.hInstance
hHook = SetWindowsHookEx(WH_CBT, AddressOf WinProc, hAppInstance, GetCurrentThreadId)
vbTimedMsgBox = MsgBox(Replace(Prompt, "%T", CStr(TimeOut / 1000)), Buttons, Title, HelpFile, Context)
KillTimer 0&, lTimerHandle
End Function

Private Function WinProc(ByVal lMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim hwndCaption As Long
Dim CurrentStyle As Long
Dim ClassName As String
Dim lResult As Long
Dim TimeOut As Long

If lMsg = HCBT_ACTIVATE Then
  ClassName = Space(256)
  lResult = GetClassName(wParam, ClassName, 256)
  If Left(ClassName, lResult) = "#32770" Then 'Make sure we spotted a messagebox (dialog).
    hwndMsgBox = wParam
    TimeOut = cm.lInterval
    If TimeOut = 0 Then TimeOut = cm.lTimeout
    If cm.lTimeout Then lTimerHandle = SetTimer(0&, 0&, TimeOut, AddressOf TimerHandler)
    UnhookWindowsHookEx hHook
  End If
End If

WinProc = False
End Function

Private Sub TimerHandler(hwnd As Long, uMSG As Integer, idEvent As Integer, dwTime As Double)
Dim hWndTargetBtn As Long

cm.lTimeout = cm.lTimeout - cm.lInterval 'Being a bit cheap here - as a result don't expect particualrly accurate timing.

SetDlgItemText hwndMsgBox, IDPROMPT, Replace(cm.strPrompt, "%T", CStr(cm.lTimeout / 1000))

If cm.lTimeout <= 0 Then
  hWndTargetBtn = GetDlgItem(hwndMsgBox, cm.lExitButton)
  
  'Set the focus to the target button and
  'simulate a click to close the dialog and
  'return the correct value.
  If hWndTargetBtn <> 0 Then
    SetFocus hWndTargetBtn
    DoEvents
    Call PostMessage(hWndTargetBtn, WM_LBUTTONDOWN, 0, ByVal 0&)
    Call PostMessage(hWndTargetBtn, WM_LBUTTONUP, 0, ByVal 0&)
  End If
End If
End Sub

Sub test()
'If vbTimedMsgBox("Displays a message in a dialog box." & vbCrLf & vbCrLf _
'  & "Self closing." & vbCrLf _
'  & "Count down display." & vbCrLf & vbCrLf _
'  & "Closing in %T seconds", vbOKCancel + vbInformation, "Timed MessageBox", , , 5000, 1000, IDCANCEL) = vbCancel Then
'
'  MsgBox "Cancel"
'  Exit Sub
'End If
'
'MsgBox "OK"
'
vbTimedMsgBox "Displays a message in a dialog box." & vbCrLf & vbCrLf _
  & "Self closing." & vbCrLf _
  & "Count down display." & vbCrLf & vbCrLf _
  & "Closing in %T seconds", vbOKOnly + vbInformation, "Timed MessageBox", , , 5000, 1000, idok
  
MsgBox "END"
End Sub 

RE: Compile Error Automation Type Not Supported In Visual Basic

Yep, that's some code I recognise. Ok, so you need to know that the Windows API constants do not mean the same as trhe VB constants. In a msgbox with just an OK button (vbOKOnly) the OK button is IDCANCEL, so your line should work as

CODE

    & "Closing in %T seconds", vbOKOnly + vbInformation, "Timed MessageBox", , , 5000, 1000, IDCANCEL 


RE: Compile Error Automation Type Not Supported In Visual Basic

(OP)
Indeed it does, and once again I'm indebted to you.

Red Flag This Post

Please let us know here why this post is inappropriate. Reasons such as off-topic, duplicates, flames, illegal, vulgar, or students posting their homework.

Red Flag Submitted

Thank you for helping keep Tek-Tips Forums free from inappropriate posts.
The Tek-Tips staff will check this out and take appropriate action.

Reply To This Thread

Posting in the Tek-Tips forums is a member-only feature.

Click Here to join Tek-Tips and talk with other members!

Resources

Close Box

Join Tek-Tips® Today!

Join your peers on the Internet's largest technical computer professional community.
It's easy to join and it's free.

Here's Why Members Love Tek-Tips Forums:

Register now while it's still free!

Already a member? Close this window and log in.

Join Us             Close