Почему я получаю «Несоответствие типов» - Ошибка 13? - PullRequest
0 голосов
/ 22 декабря 2018

Я нашел некоторый код для изменения размера окна сообщения проверки данных, но он 32-разрядный, и я использую 64-разрядную версию Excel.Я обновил все ссылки на Private Declare Function, чтобы сказать Private Declare PtrSafe Function.

Код проходит через все это сейчас, но я получаю ошибку 13 Несоответствие типов.Этот код находится в стандартном модуле.

Public Sub StartTimer _
(ByVal MsgTitle As String, ByVal MsgInput As String)

'store the DV imput & title
'messages in global vars.

sInputTitle = MsgTitle
sInputMessage = MsgInput

'initiate SetWindowPos flag.
bFirstCall = True

'timer to run the 'FormatDVMsg' routine.
'required to work async with the Selection_Change
'event.Doesn't put a strain on the system
'as it only runs once upon a cell selection.

lTimerID = SetTimer(0, 0, 1, AddressOf TimerProc)

End Sub

Последняя строка кода AddressOf TimerProc выделяется синим цветом, когда появляется окно ошибки.

Я могу ошибаться, но я считаю,код работает с подпрограммой, которую я поместил в соответствующий модуль рабочего листа.Я делаю это предположение, потому что они оба имеют дело с каким-то Таймером.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

     Dim sTitle As String, sInput As String

     On Error Resume Next

     '***********************
      'shouldn't be necessary
      'but just in case.
      Set wb = ThisWorkbook
    '**********************

    sTitle = Target.Validation.InputTitle
    sInput = Target.Validation.InputMessage

    If Len(sInput & sTitle) <> 0 Then
        Call StartTimer(ByVal sTitle, ByVal sInput)
    End If

    ClearHook

End Sub

Я ничего не знаю о VBA, кроме лакомых кусочков, которые я подбираю, когда мне нужно что-то сделать, а потом почти сразу забываю, когда яне используйте его снова какое-то время.Я не делаю это ежедневно.Я опубликую весь приведенный ниже код на случай, если он понадобится кому-либо, чтобы помочь мне в этом.Заранее спасибо.Ребята, вы великолепны!

Цель всего этого - изменить размер окна сообщения проверки данных.Я еще не знаю, будет ли это работать, но я надеюсь, что это будет работать.

В модуле рабочего листа:

Private Sub wb_BeforeClose(Cancel As Boolean)

   'safety measure in case
   'the wb is not unhooked before closing.
        If lPrevWnd Then Call ClearHook

End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    Dim sTitle As String, sInput As String

    On Error Resume Next

   '***********************
    'shouldn't be necessary
    'but just in case.
    Set wb = ThisWorkbook
   '**********************

    sTitle = Target.Validation.InputTitle
    sInput = Target.Validation.InputMessage

    If Len(sInput & sTitle) <> 0 Then
        Call StartTimer(ByVal sTitle, ByVal sInput)
    End If

   ClearHook

End Sub

В стандартном модуле:

Option Explicit

Private Type POINTAPI
    x As Long
    y As Long
End Type

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

Private Type PAINTSTRUCT
    hdc As Long
    fErase As Long
    rcPaint As RECT
    fRestore As Long
    fIncUpdate As Long
    rgbReserved(32) As Byte
End Type

Private Type LOGFONT
    lfHeight As Long
    lfWidth As Long
    lfEscapement As Long
    lfOrientation As Long
    lfWeight As Long
    lfItalic As String * 1
    lfUnderline As String * 1
    lfStrikeOut As String * 1
    lfCharSet As String * 1
    lfOutPrecision As String * 1
    lfClipPrecision As String * 1
    lfQuality As String * 1
    lfPitchAndFamily As String * 1
    lfFaceName As String * 32
End Type

Private Type MSG
    hwnd As Long
    message As Long
    wParam As Long
    lParam As Long
    time As Long
    pt As POINTAPI
End Type

Private Declare PtrSafe Function FindWindow Lib "user32.dll" _
Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long

Private Declare PtrSafe Function FindWindowEx Lib "user32.dll" _
Alias "FindWindowExA" _
(ByVal hWnd1 As Long, _
ByVal hWnd2 As Long, _
ByVal lpsz1 As String, _
ByVal lpsz2 As String) As Long

Private Declare PtrSafe Function CreateFontIndirect Lib "gdi32" _
Alias "CreateFontIndirectA" _
(lpLogFont As LOGFONT) As Long

Private Declare PtrSafe Function GetWindowDC Lib "user32" _
 (ByVal hwnd As Long) As Long

Private Declare PtrSafe Function ReleaseDC Lib "user32" _
(ByVal hwnd As Long, _
ByVal hdc As Long) As Long

Private Declare PtrSafe Function SetBkMode Lib "gdi32" _
(ByVal hdc As Long, _
ByVal nBkMode As Long) As Long

Private Declare PtrSafe Function SelectObject Lib "gdi32" _
(ByVal hdc As Long, _
ByVal hObject As Long) As Long

Private Declare PtrSafe Function SetWindowLong Lib "user32" _
Alias "SetWindowLongA" _
(ByVal hwnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long

Private Declare PtrSafe 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 PtrSafe Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long

Private Declare PtrSafe Function SetTextColor Lib "gdi32" _
(ByVal hdc As Long, _
ByVal crColor As Long) As Long

Private Declare PtrSafe Function CreateBrushIndirect Lib "gdi32" _
(lpLogBrush As LOGBRUSH) As Long

Private Declare PtrSafe Function FillRect Lib "user32.dll" _
(ByVal hdc As Long, _
ByRef lpRect As RECT, _
ByVal hBrush As Long) As Long

Private Declare PtrSafe Function BeginPaint Lib "user32.dll" _
(ByVal hwnd As Long, _
ByRef lpPaint As PAINTSTRUCT) As Long

Private Declare PtrSafe Function EndPaint Lib "user32.dll" _
(ByVal hwnd As Long, _
ByRef lpPaint As PAINTSTRUCT) As Long

Private Declare PtrSafe Function DeleteDC Lib "gdi32" _
(ByVal hdc As Long) As Long

Private Declare PtrSafe Function SetTimer Lib "user32.dll" _
(ByVal hwnd As Long, _
ByVal nIDEvent As Long, _
ByVal uElapse As Long, _
ByVal lpTimerFunc As Long) As Long

Private Declare PtrSafe Function KillTimer Lib "user32.dll" _
(ByVal hwnd As Long, _
ByVal nIDEvent As Long) As Long

Private Declare PtrSafe Function GetClientRect Lib "user32.dll" _
(ByVal hwnd As Long, _
ByRef lpRect As RECT) As Long

Private Declare PtrSafe Function GetMessage Lib "user32.dll" _
Alias "GetMessageA" _
(ByRef lpMsg As MSG, _
ByVal hwnd As Long, _
ByVal wMsgFilterMin As Long, _
ByVal wMsgFilterMax As Long) As Long

Private Declare PtrSafe Function TranslateMessage Lib "user32.dll" _
(ByRef lpMsg As MSG) As Long

Private Declare PtrSafe Function PostMessage Lib "user32.dll" _
Alias "PostMessageA" _
(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long

Private Declare PtrSafe Function DrawText Lib "user32" _
Alias "DrawTextA" _
(ByVal hdc As Long, _
ByVal lpStr As String, _
ByVal nCount As Long, _
lpRect As RECT, _
ByVal wFormat As Long) As Long

Private Declare PtrSafe Function DrawEdge Lib "user32" _
(ByVal hdc As Long, _
qrc As RECT, _
ByVal edge As Long, _
ByVal grfFlags As Long) As Long

Private Declare PtrSafe Function InvalidateRect Lib "user32.dll" _
(ByVal hwnd As Long, _
ByVal lpRect As Long, _
ByVal bErase As Long) As Long

Private Declare PtrSafe Function SetWindowPos Lib "user32.dll" _
(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 PtrSafe Function GetWindowRect Lib "user32.dll" _
(ByVal hwnd As Long, _
ByRef lpRect As RECT) As Long

'========================================
'System Constantes.
Private Const GWL_WNDPROC As Long = -4
Private Const WM_PAINT As Long = &HF&
Private Const SWP_NOMOVE As Long = &H2
Private Const SWP_NOACTIVATE As Long = &H10
Private Const DT_WORDBREAK As Long = &H10

Private Const BDR_RAISEDOUTER As Long = &H1
Private Const BDR_SUNKENINNER As Long = &H8
Private Const EDGE_BUMP As Long = _
(BDR_RAISEDOUTER Or BDR_SUNKENINNER)
Private Const BF_LEFT As Long = &H1
Private Const BF_RIGHT As Long = &H4
Private Const BF_TOP As Long = &H2
Private Const BF_BOTTOM As Long = &H8
Private Const BF_RECT As Long = _
(BF_LEFT Or BF_TOP Or BF_RIGHT Or BF_BOTTOM)
'=====================================

'User global Constantes.
'Change their values as required.
Private Const TITLE_FONT_HEIGHT = 16
Private Const TITLE_FONT_WIDTH = 6
Private Const TITLE_FONT_BOLD = True
Private Const TITLE_FONT_COLOR = vbRed
Private Const INPUT_FONT_HEIGHT = 14
Private Const INPUT_FONT_WIDTH = 5
Private Const INPUT_FONT_BOLD = False
Private Const INPUT_FONT_COLOR = vbBlue
Private Const INPUT_BCKG_COLOR = vbCyan

'this is the DV input msg box
'class name in XL 2003.
'not sure about other XL versions.
Private Const DV_INPUT_MSG_CLASS As String = "EXCELA"
'====================================

'Module variables.
Private tWnRect As RECT
Private tClientRect As RECT
Private bXitLoop As Boolean
Private bFirstCall As Boolean
Private sInputMessage As String
Private sInputTitle As String
Private lDVhwnd As Long
Private lTimerID As Long
Private ldc As Long
'==============================

'Global Vars.
Public lPrevWnd As Long


Private Function CallBackProc _
(ByVal hwnd As Long, ByVal MSG As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long


    Dim tPS As PAINTSTRUCT
    Dim tLB As LOGBRUSH
    Dim hBrush As Long


    On Error Resume Next

   'build the default brush.
    tLB.lbColor = INPUT_BCKG_COLOR
    hBrush = CreateBrushIndirect(tLB)

   'store the DV dimensions.
    GetClientRect hwnd, tClientRect
    GetWindowRect hwnd, tWnRect

    'intercept the WM_PAINT Msg.
    Select Case MSG

        Case WM_PAINT

            If bFirstCall Then
                SetWindowPos hwnd, 0, 0, 0, _
                tWnRect.Right - tWnRect.Left, _
                (tWnRect.Bottom - tWnRect.Top) + 10, _
                SWP_NOACTIVATE + SWP_NOMOVE
                bFirstCall = False
            End If

           'start the text & bckgrnd formatting.
            ldc = BeginPaint(hwnd, tPS)

            SetBkMode ldc, 1

            FillRect ldc, tClientRect, hBrush

            DrawEdge ldc, tClientRect, EDGE_BUMP, BF_RECT

            tClientRect.Left = tClientRect.Left + 5
            tClientRect.Top = tClientRect.Top + 5

            SetTextColor ldc, TITLE_FONT_COLOR

            sInputTitle = sInputTitle & vbNewLine & vbNewLine

            CreateTitleFont ldc, sInputTitle

            DrawText ldc, sInputTitle, Len(sInputTitle), _
            tClientRect, DT_WORDBREAK

            SetTextColor ldc, INPUT_FONT_COLOR

            CreateInputFont ldc, sInputTitle

            tClientRect.Top = tClientRect.Top + 20

            DrawText ldc, sInputMessage, Len(sInputMessage), _
            tClientRect, DT_WORDBREAK

            Call DeleteObject(hBrush)

            ReleaseDC hwnd, ldc

            EndPaint hwnd, tPS

    End Select

    'process other msgs.
    CallBackProc = CallWindowProc _
    (lPrevWnd, hwnd, MSG, wParam, ByVal lParam)

End Function

Private Sub CreateTitleFont(DC As Long, text As String)

    Dim uFont As LOGFONT
    Dim lNewFont As Long

    With uFont
        .lfFaceName = "Arial" & Chr$(0)
        .lfUnderline = True
        .lfHeight = TITLE_FONT_HEIGHT
        .lfWidth = TITLE_FONT_WIDTH
        .lfWeight = IIf(TITLE_FONT_BOLD, 900, 100)

    End With

    lNewFont = CreateFontIndirect(uFont)
    DeleteObject (SelectObject(DC, lNewFont))

End Sub

Private Sub CreateInputFont(DC As Long, text As String)

    Dim uFont As LOGFONT
    Dim lNewFont As Long

    With uFont
        .lfFaceName = "Arial" & Chr$(0)
        .lfHeight = INPUT_FONT_HEIGHT
        .lfWidth = INPUT_FONT_WIDTH
        .lfWeight = IIf(INPUT_FONT_BOLD, 900, 100)
    End With

    lNewFont = CreateFontIndirect(uFont)
    DeleteObject (SelectObject(DC, lNewFont))

End Sub

Private Sub FormatDVMsg _
(ByVal MsgTitle As String, ByVal MsgInput As String)

    If lPrevWnd = 0 Then
        lPrevWnd = SetWindowLong _
        (lDVhwnd, GWL_WNDPROC, AddressOf CallBackProc)

       'send a Paint Msg to the DV box upon showing up.
        InvalidateRect lDVhwnd, 0, 0
       'important!!!
        ' Msg pump for safe subclassing !!!!
        Call MessageLoop
    End If


End Sub

Private Sub MessageLoop()

    Dim aMsg As MSG

    bXitLoop = False

    On Error Resume Next

   'ensure all Msgs are posted during the subclassing.
    Do While GetMessage(aMsg, 0, 0, 0) And bXitLoop = False
        DoEvents
        PostMessage 0, aMsg.message, aMsg.wParam, aMsg.lParam
    Loop

End Sub

Public Sub StartTimer _
(ByVal MsgTitle As String, ByVal MsgInput As String)

    'store the DV imput & title
   'messages in global vars.

    sInputTitle = MsgTitle
    sInputMessage = MsgInput

   'initiate SetWindowPos flag.
    bFirstCall = True

   'timer to run the 'FormatDVMsg' routine.
   'required to work async with the Selection_Change
    'event.Doesn't put a strain on the system
    'as it only runs once upon a cell selection.

    lTimerID = SetTimer(0, 0, 1, AddressOf TimerProc)

End Sub

Public Sub ClearHook()

    'cleanUp.
    bXitLoop = True
    SetWindowLong lDVhwnd, GWL_WNDPROC, lPrevWnd
    lPrevWnd = 0
    lDVhwnd = 0
    bFirstCall = True

End Sub

Private Sub TimerProc()

    lDVhwnd = FindWindowEx _
    (FindWindow("XLMAIN", Application.Caption), _
    0, DV_INPUT_MSG_CLASS, vbNullString)

    If lDVhwnd <> 0 Then
        KillTimer 0, lTimerID
        Call FormatDVMsg(ByVal sInputTitle, ByVal sInputMessage)
    End If

End Sub
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.
...