将 ImageCombo-ActiveX 添加到工作表时出现 Excel VBA 问题

Question

I'm trying to add an ImageCombo-ActiveX control to an Excel worksheet by using the VBA-function.OLEObjects.Add(classtype:="MSComctlLib.ImageComboCtl.2", Top:=TopPos, Left:=LeftPos, Height:=0, Width:=0).

When doing so, the ImageCombo control is displayed on the worksheet in a preloaded state: ImageCombo Preloaded State

When doing a check with Winspector Spy, it turned out then the ActiveX-Window is loaded as a child-window of an invisible window within Excel named as 'CtlFrameworkParking': ActiveX control window

instead of being diplayed as an ImageCombo-control. To force this, I first have to make the worksheet window invisble and then redisplay it: Status after Re-displaying the worksheet window

Finally, after manually scrolling down a line, the ImageCombo-control is diplayed at the desired location with the desired size. Status after worksheet scroll

Reinspecting with Winspector Spy the ActiveX-Window now is located within the worksheet window: final correct status

Is there any way to programatically force the ActiveX-Window to show in final state on the worksheet window, probably with some api calls?

Answer 1

I Solved the problem doing it the dirty way by adding the following lines:

Function ShowLanguageDropDown(TargetSheetName As String, Optional TopPos As Single = 0#, Optional LeftPos As Single = 0#, Optional SetVisible As Boolean = False) As MSComctlLib.ImageCombo
'---------------------------------------------------------------------------------------
' Procedure : ShowLanguageDropDown
' Author    : Bernd Birkicht
' Date      : 05.11.2022
' Purpose   : inserts an image dropdown on the target sheet, requires prelodad OLE-objects on a SourceSheet
'             containing the ImageDropdown and the to be associated pre-set ImageList-activeX control
'---------------------------------------------------------------------------------------
'
'........
Set TargetSheet = ActiveWorkbook.Sheets(TargetSheetName)
'........

With TargetSheet
  .Visible = xlSheetHidden
  .Visible = xlSheetVisible
  .Activate
End With
Set TargetSheet = Nothing

CurrentScrollRow = ActiveWindow.ScrollRow
ActiveWindow.ScrollRow = 2
ActiveWindow.ScrollRow = CurrentScrollRow
End function

These commands now do programmatically what I did manually before resulting in now correctly displaying the ImageDropdown control at the desired location on the worksheet.

I would welcome a more elegant solution.

Answer 2

I finally decided to to drop the approach of using an ImageCombo-ActiveX control directly on an Excel worksheet due to i encounterd a big bunch of problems with the ImageCombo-control further on.

When stopping the screen update, the Drop-down arrow within the control occasionally disappears and the control repaints not always fully. I was not able to fix this.

At the end of the day, I used the ImageCombo-ActiveX control within a modeless userform which is not affected at all from application screen updating or events processed by the application while the userform is displayed.

To prevent the userform from floating on the windows screen, I now attached the userform to the Excel-application window and cropped the userform frame around the ImageCombo-control.

Please find below the code:

Private Sub UserForm_Initialize()
'---------------------------------------------------------------------------------------
' Procedure : UserForm_Initialize
' Author    : Bernd Birkicht
' Date      : 10.11.2022
' Purpose   : fills the image-Dropdownbox valid lnaguage entries
'---------------------------------------------------------------------------------------
'
  Static BasicInit As Boolean

  On Error GoTo UserForm_Initialize_Error

  If BasicInit Then Exit Sub    'already initialised?

....
  'adapt userform window to  Dropbox size
  Me.Height = Me!LanguageDropBox.Height
  Me.Width = Me!LanguageDropBox.Width

  With Me.LanguageDropBox
    Set .ImageList = Nothing          'delete image list and import again
    If .ImageList Is Nothing Then Set .ImageList = Me.LanguageSmallIconImageList
    mlngptrCtlHwnd = .hwnd
    .Locked = True
  End With

  PopulateComboItems Translate:=bTranslate

UserForm_Initialize_Exit:
  Crop_UF_Frame
  BasicInit = MakeChild(Me)
  
  Exit Sub

UserForm_Initialize_Error:
  Select Case Err.Number

  Case Else
    'MsgBox "Error " & Err.Number & " (" & Err.Description & ") in Prozedur UserForm_Initialize aus Formular LanguageDropBoxForm"
    'LogError Err.Number, Err.Description, "in Prozedur UserForm_Initialize aus Formular LanguageDropBoxForm"
    ErrEx.CallGlobalErrorHandler        ' Call the global error handler to deal with unhandled errors
    Resume UserForm_Initialize_Exit:
  End Select

End Sub



Private Sub Crop_UF_Frame()
'---------------------------------------------------------------------------------------
' Procedure : Crop_UF_Frame
' Author    : Nepumuk https://www.herber.de/forum/archiv/1456to1460/1459854_Userform_komplett_ohne_Rand.html
' Date      : 21.11.2015
' Purpose   : crop the userform frame
' geändert  : 11.11.2022 Bernd Birkicht
'             ergänzt: Region eingrenzen auf einzelnes Control in der Userform
'---------------------------------------------------------------------------------------
'
  Dim udtRect As RECT, udtPoint As POINTAPI
  Dim lngptrStyle As LongPtr, lngptrRegion As LongPtr, lngParenthWnd As LongPtr
  Static BasicInit As Boolean

  On Error GoTo Crop_UF_Frame_Error

  mlngptrHwnd = FindWindowA(GC_CLASSNAMEMSFORM, Caption)

  lngptrStyle = GetWindowLongA(mlngptrHwnd, GWL_STYLE)
  Call SetWindowLongA(mlngptrHwnd, GWL_STYLE, lngptrStyle And Not WS_CAPTION)
  Call DrawMenuBar(mlngptrHwnd)

  Call GetWindowRect(mlngptrHwnd, udtRect)
  udtPoint.x = udtRect.right
  udtPoint.y = udtRect.bottom

  Call ScreenToClient(mlngptrHwnd, udtPoint)

  '11.11.2022 set region
  If mlngptrCtlHwnd = 0 Then  'Control in Userform gewählt?
    'remove userform frame
    With udtRect
      .bottom = udtPoint.y
      .left = 4
      .right = udtPoint.x
      .top = 4
    End With
  Else
    'set region to WindowRect of the selected control
    Call GetWindowRect(mlngptrCtlHwnd, udtRect)
  End If

  lngptrRegion = CreateRectRgnIndirect(udtRect)
  Call SetWindowRgn(mlngptrHwnd, lngptrRegion, 1&)

Crop_UF_Frame_Exit:
  Exit Sub

Crop_UF_Frame_Error:
  Select Case Err.Number

  Case Else
    ErrEx.CallGlobalErrorHandler        ' Call the global error handler to deal with unhandled errors
    Resume Crop_UF_Frame_Exit:
  End Select
End Sub


Private Function MakeChild(ByVal UF As UserForm) As Boolean
  Dim DeskHWnd As LongPtr
  Dim WindowHWnd As LongPtr
  Dim UFhWnd As LongPtr

  MakeChild = False

  ' get the window handle of the Excel desktop
  DeskHWnd = FindWindowEx(Application.hwnd, 0&, "XLDESK", vbNullString)
  If DeskHWnd > 0 Then
    ' get the window handle of the ActiveWindow
    WindowHWnd = FindWindowEx(DeskHWnd, 0&, "EXCEL7", ActiveWindow.Caption)
    If WindowHWnd > 0 Then
      ' ok
    Else
      MsgBox "Unable to get the window handle of the ActiveWindow."
      Exit Function
    End If
  Else
    MsgBox "Unable to get the window handle of the Excel Desktop."
    Exit Function
  End If

' get the window handle of the userform
  Call IUnknown_GetWindow(UF, VarPtr(UFhWnd))
  mlngptrOldParenthWnd = GetParent(UFhWnd)
  If mlngptrOldParenthWnd = WindowHWnd Then Exit Function  'Assignment to Excel window already done

  'make the userform a child window of the MDIForm
  If (UFhWnd > 0) And (WindowHWnd > 0) Then
    ' make the userform a child window of the ActiveWindow
    If SetParent(UFhWnd, WindowHWnd) = 0 Then
      ''''''''''''''''''''
      ' an error occurred.
      ''''''''''''''''''''
      MsgBox "The call to SetParent failed."
      Exit Function
    End If
  End If

  MakeChild = True
End Function

call:

    If Wb.ActiveSheet.Name = Translate_To_OriginalText(InitSheetName) And LanguageDropBoxUForm Is Nothing Then
      LanguageDropBoxForm.Hide        'Lädt das Window ohne es anzuzeigen
      If UserForms.count > 0 Then Set LanguageDropBoxUForm = UserForms(UserForms.count - 1)
      LanguageDropBoxForm.Move 660#, 85#
      LanguageDropBoxForm.Show vbModeless     'show Language-Select-Window modeless
    endif