Can a userform multipage backcolor be changed? - Page 4

Thanks Thanks:  0
Page 4 of 4 FirstFirst ... 234
Results 31 to 32 of 32

Thread: Can a userform multipage backcolor be changed?

  1. #31
    Board Regular Jaafar Tribak's Avatar
    Join Date
    Dec 2002
    Location
    Larache--Morocco
    Posts
    6,236
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Can a userform multipage backcolor be changed?

     
    Here is a much simpler API-based method which should also work with scrollable multipages.

    Code in the UserForm Module :

    Code:
    Option Explicit
    
    Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
    End Type
    
    Private Type uPicDesc
        Size As Long
        Type As Long
        #If VBA7 Then
            hPic As LongPtr
            hPal As LongPtr
        #Else
           hPic As Long
           hPal As Long
        #End If
    End Type
    
    Private Type GUID
        Data1 As Long
        Data2 As Integer
        Data3 As Integer
        Data4(0 To 7) As Byte
    End Type
    
    #If VBA7 Then
        #If Win64 Then
            Private Declare PtrSafe Function OleCreatePictureIndirect Lib "OleAut32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
        #Else
            Private Declare PtrSafe Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
        #End If
        Private Declare PtrSafe Function CopyImage Lib "user32" (ByVal handle As LongPtr, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As LongPtr
        Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
        Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
        Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
        Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As LongPtr) As LongPtr
        Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
        Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr
        Private Declare PtrSafe Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As LongPtr
        Private Declare PtrSafe Function FillRect Lib "user32" (ByVal hdc As LongPtr, lpRect As RECT, ByVal hBrush As LongPtr) As Long
        Private Declare PtrSafe Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
        Private hdc As LongPtr, hMemDc As LongPtr, hMemBmp As LongPtr, hBrush As LongPtr, hCopy As LongPtr, ar() As LongPtr
    #Else
        Private Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
        Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
        Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
        Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
        Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
        Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
        Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
        Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
        Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
        Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
        Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
        Private hdc As Long, hMemDc As Long, hMemBmp As Long, hBrush As Long, hCopy As Long, ar() As Long
    #End If
    
    Private Const IMAGE_BITMAP = 0
    Private Const PICTYPE_BITMAP = 1
    Private Const LR_COPYRETURNORG = &H4
    Private Const S_OK = 0
    
    Private Sub UserForm_Initialize()
     
        '// Set the Pages BackColors .
     
        Call SetBackColor(Page:=MultiPage1.Pages(0), BackColor:=vbRed)
        Call SetBackColor(Page:=MultiPage1.Pages(1), BackColor:=RGB(20, 200, 100))
     
    End Sub
    
    Private Sub UserForm_Terminate()
        Call DeleteResources
    End Sub
    
    
    Private Sub SetBackColor(Page As MSForms.Page, BackColor As Long)
    
        Dim R As RECT
        Dim IID_IDispatch As GUID
        Dim uPicinfo As uPicDesc
        Dim IPic As IPicture
        Static i As Integer
        
        hdc = GetDC(0)
        SetRect R, 0, 0, 1, 1
    
        With R
            hMemBmp = CreateCompatibleBitmap(hdc, .Right - .Left, .Bottom - .Top)
        End With
    
        hMemDc = CreateCompatibleDC(hdc)
        DeleteObject SelectObject(hMemDc, hMemBmp)
        hBrush = CreateSolidBrush(BackColor)
        FillRect hMemDc, R, hBrush
        hCopy = CopyImage(hMemBmp, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
    
        With IID_IDispatch
            .Data1 = &H20400
            .Data4(0) = &HC0
            .Data4(7) = &H46
        End With
      
        With uPicinfo
            .Size = Len(uPicinfo)
            .Type = PICTYPE_BITMAP
            .hPic = hCopy
            .hPal = 0
        End With
    
        Page.PictureSizeMode = fmPictureSizeModeStretch
        If OleCreatePictureIndirect(uPicinfo, IID_IDispatch, True, IPic) = S_OK Then
            Set Page.Picture = IPic
        Else
            MsgBox "Unable to create Picture", vbCritical, "Error."
        End If
    
        DeleteObject hMemBmp
        DeleteObject hMemDc
        DeleteObject hBrush
        ReleaseDC 0, hdc
    
        ReDim Preserve ar(i)
        ar(i) = hCopy
        i = i + 1
    
    End Sub
    
    Private Sub DeleteResources()
    
        Dim element As Variant
        
        For Each element In ar
            DeleteObject element
        Next
    
    End Sub
    Last edited by Jaafar Tribak; Nov 10th, 2017 at 01:39 PM.
    Office/Excel 2010 64Bits -- Win10 64Bits

    Common sense is not so common.


    http://photo-larache.blogspot.com/

  2. #32
    New Member
    Join Date
    Nov 2017
    Posts
    2
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Can a userform multipage backcolor be changed?

      
    Thanks Jaafar, this works for me. Only thing is that I moved the code outside of the userform and into a normal module because I want to use the code for more than 1 form.

User Tag List

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  

 

 
DMCA.com