Multipage Backcolor ändern
#1
Huhu,

ich habe folgenden Code gefunden, der die Hintergrundfarbe von Multipages ändern können soll.

Allerdings bekomme ich immer einen Laufzeitfehler 75, Datei nicht gefunden.
Ich finde aber keine Stelle, an der auf eine Datei referenziert wird?


Code:
' // This code Sets the BackColor of
' // Pages on a Multipage Control.(Excel)
'*******************************
Option Explicit

'=============================
' // Private Declarations..
'=============================

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 BITMAPINFOHEADER '40 bytes
   biSize As Long
   biWidth As Long
   biHeight As Long
   biPlanes As Integer
   biBitCount As Integer
   biCompression As Long
   biSizeImage As Long
   biXPelsPerMeter As Long
   biYPelsPerMeter As Long
   biRUsed As Long
   biRImportant As Long
End Type

' A BITMAPINFO structure for bitmaps with no color palette.
Private Type BITMAPINFO_NoColors
   bmiHeader As BITMAPINFOHEADER
End Type

Private Type BITMAPFILEHEADER
   bfType As Integer
   bfSize As Long
   bfReserved1 As Integer
   bfReserved2 As Integer
   bfOffBits As Long
End Type

Private Type MemoryBitmap
   hdc As Long
   hbm As Long
   oldhDC As Long
   wid As Long
   hgt As Long
   bitmap_info As BITMAPINFO_NoColors
End Type

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

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

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

Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) _
As Long

Private Declare Function CreateDIBSection Lib "gdi32" _
(ByVal hdc As Long, pBitmapInfo As BITMAPINFO_NoColors, _
ByVal un As Long, ByVal lplpVoid As Long, _
ByVal handle As Long, ByVal dw As Long) _
As Long

Private Declare Function GetDIBits Lib "gdi32" _
(ByVal aHDC As Long, ByVal hBitmap As Long, ByVal _
nStartScan As Long, ByVal nNumScans As Long, _
lpBits As Any, lpBI As BITMAPINFO_NoColors, _
ByVal wUsage 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 SetBkMode Lib "gdi32.dll" _
(ByVal hdc As Long, ByVal nBkMode As Long) _
As Long

Private Declare Function CreateBrushIndirect Lib "gdi32" _
(lpLogBrush As LOGBRUSH) As Long
Private Declare Function FillRect Lib "user32" _
(ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long

Private Const DIB_RGB_COLORS = 0&
Private Const BI_RGB = 0&

'=============================
' // Public Routines.
'=============================
Public Sub SetBackColor(Page As MSForms.Page, Color As Long)

   Const sBMPFile As String = "C:\Temp.bmp"
   Dim memory_bitmap As MemoryBitmap

   ' Create the memory bitmap.
   memory_bitmap = MakeMemoryBitmap _
   (Page)

   ' Draw on the bitmap.
   DrawOnMemoryBitmap memory_bitmap, Color

   ' Save the bmp.
   Call SaveMemoryBitmap(memory_bitmap, sBMPFile)

   ' load the bmp onto the page.
   Set Page.Picture = LoadPicture(sBMPFile)

   ' Delete the memory bitmap.
   DeleteMemoryBitmap memory_bitmap

   ' Delete BMP file.
   Kill sBMPFile

End Sub



'=============================
' // Private Routines.
'=============================

' Make a memory bitmap according to the MultiPage size.
Private Function MakeMemoryBitmap _
(Page As MSForms.Page) As MemoryBitmap

   Dim result As MemoryBitmap
   Dim bytes_per_scanLine As Long
   Dim pad_per_scanLine As Long
   Dim new_font As Long

   ' Create the device context.
   result.hdc = CreateCompatibleDC(0)


   ' Define the bitmap.
   With result.bitmap_info.bmiHeader
       .biBitCount = 32
       .biCompression = BI_RGB
       .biPlanes = 1
       .biSize = Len(result.bitmap_info.bmiHeader)
       .biWidth = Page.Parent.Parent.Width 'wid
       .biHeight = Page.Parent.Parent.Height ' hgt
       bytes_per_scanLine = ((((.biWidth * .biBitCount) + _
       31) \ 32) * 4)
       pad_per_scanLine = bytes_per_scanLine - (((.biWidth _
       * .biBitCount) + 7) \ 8)
       .biSizeImage = bytes_per_scanLine * Abs(.biHeight)
   End With

   ' Create the bitmap.
   result.hbm = CreateDIBSection( _
   result.hdc, result.bitmap_info, _
   DIB_RGB_COLORS, ByVal 0&, _
   ByVal 0&, ByVal 0&)

   ' Make the device context use the bitmap.
   result.oldhDC = SelectObject(result.hdc, result.hbm)

   ' Return the MemoryBitmap structure.
   result.wid = Page.Parent.Parent.Width
   result.hgt = Page.Parent.Parent.Height

   MakeMemoryBitmap = result

End Function

Private Sub DrawOnMemoryBitmap( _
memory_bitmap As _
MemoryBitmap, Color As Long _
)

  Dim LB As LOGBRUSH, tRect As RECT
  Dim hBrush As Long

  LB.lbColor = Color

  'Create a new brush
   hBrush = CreateBrushIndirect(LB)
   With memory_bitmap
      SetRect tRect, 0, 0, .wid, .hgt
   End With

   SetBkMode memory_bitmap.hdc, 2 'Opaque

   'Paint the mem dc.
   FillRect memory_bitmap.hdc, tRect, hBrush

End Sub

' Save the memory bitmap into a bitmap file.
Private Sub SaveMemoryBitmap( _
memory_bitmap As MemoryBitmap, _
ByVal file_name As String _
)

   Dim bitmap_file_header As BITMAPFILEHEADER
   Dim fnum As Integer
   Dim pixels() As Byte

   ' Fill in the BITMAPFILEHEADER.
   With bitmap_file_header
       .bfType = &H4D42   ' "BM"
       .bfOffBits = Len(bitmap_file_header) + _
       Len(memory_bitmap.bitmap_info.bmiHeader)
       .bfSize = .bfOffBits + _
       memory_bitmap.bitmap_info.bmiHeader.biSizeImage
   End With

   ' Open the output bitmap file.
   fnum = FreeFile
   Open file_name For Binary As fnum
   ' Write the BITMAPFILEHEADER.
   Put #fnum, , bitmap_file_header
   ' Write the BITMAPINFOHEADER.
   ' (Note that memory_bitmap.bitmap_info.bmiHeader.biHeight
   ' must be positive for this.)
   Put #fnum, , memory_bitmap.bitmap_info
   ' Get the DIB bits.
   ReDim pixels(1 To 4, _
   1 To memory_bitmap.wid, _
   1 To memory_bitmap.hgt)
   GetDIBits memory_bitmap.hdc, memory_bitmap.hbm, _
   0, memory_bitmap.hgt, pixels(1, 1, 1), _
   memory_bitmap.bitmap_info, DIB_RGB_COLORS
   ' Write the DIB bits.
   Put #fnum, , pixels
   ' Close the file.
   Close fnum

End Sub

' Delete the bitmap and free its resources.
Private Sub DeleteMemoryBitmap( _
memory_bitmap As MemoryBitmap _
)

   SelectObject memory_bitmap.hdc, memory_bitmap.oldhDC
   DeleteObject memory_bitmap.hbm
   DeleteDC memory_bitmap.hdc

End Sub
Top
#2
Hallo, :19:

du hast den Code wohl von hier: :21:

Can a userform multipage backcolor be changed...

Der funktioniert sauber. Es gibt nur ein Problem - in neueren Windowsversionen kannst du nicht ohne weiteres direkt auf "C:\" speichern. Ändere die Codezeile...


Code:
Const sBMPFile As String = "C:\Temp.bmp"

... auf einen Pfad unterhalb von "C:\". Also z. B. "C:\Temp\Temp.bmp". Der Ordner sollte natürlich vorhanden sein. :21:
[-] Folgende(r) 1 Nutzer sagt Danke an Gast für diesen Beitrag:
  • StrammerMax
Top
#3
Huhu Case,

daran lag es tatsächlich. Auf C:\Temp\Temp.bmp kann er aber leider auch nicht zugriefen. Ich muss einen direkten Pfad mit Usernamen angeben - was ziemlich blöd ist, da es ja Userunabhängig funktionieren sollte.

"C:\Users\MEINNAME\Desktop.bmp" funktioniert. Aber durch meinen Username funktioniert es dann auch nur bei mir.

Zweites "Problemchen" - er füllt nicht die komplette Multipage mit Farbe.

   
Top
#4
Hallo, :19:

dann musst du mit "Environ" arbeiten. Dann kannst du allerdings nicht mehr mit der Konstante arbeiten...


Code:
Const sBMPFile As String = "C:\Temp\Temp.bmp"

Ersetze diese Zeile durch: :21:



Code:
Dim sBMPFile As String
sBMPFile = Environ("UserProfile") & "\Temp.bmp"
[-] Folgende(r) 1 Nutzer sagt Danke an Gast für diesen Beitrag:
  • StrammerMax
Top
#5
Du bist einfach der Beste :23:

Jetzt fehlt nur noch, dass auch das komplette Fenster mit Farbe gefüllt wird :05:
Top
#6
Hi

schau mal in den Link von Case. Wenn ich richtig gelesen habe wird genau das Problem dann in #15 behoben.

Gruß Elex
[-] Folgende(r) 1 Nutzer sagt Danke an Elex für diesen Beitrag:
  • StrammerMax
Top
#7
(21.01.2019, 11:13)Elex schrieb: Hi

schau mal in den Link von Case. Wenn ich richtig gelesen habe wird genau das Problem dann in #15 behoben.

Gruß Elex

Perfekt - funktioniert einwandfrei.

Vielen Dank :)
Top
#8
Wenn das mit der gesamten Page geht müsste das doch eigentlich auch mit dem Register / Reiter oben gehen?
Top
#9
Hallo,

also ich bin ja durchaus ein Freund von Windows-API, aber wenn es Dir nur darum geht, die Hintergrundfarbe in der Inhaltsansicht
einer MultiPage-Seite zu ändern, geht's auch ohne API: ein Label in den Hintergrund legen, was größer als die Seite ist und dann
die Hintergrundfarbe vom Label per Code oder statisch setzen.

Gruß
Microsoft Excel Expert · Microsoft Most Valuable Professional (MVP) :: 2011-2019 & 2020-2022 :: 10 Awards
https://de.excel-translator.de/translator :: Online Excel-Formel-Übersetzer :: Funktionen :: Fehlerwerte :: Argumente :: Tabellenbezeichner
[-] Folgende(r) 1 Nutzer sagt Danke an maninweb für diesen Beitrag:
  • StrammerMax
Top
#10
(21.01.2019, 14:03)maninweb schrieb: Hallo,

also ich bin ja durchaus ein Freund von Windows-API, aber wenn es Dir nur darum geht, die Hintergrundfarbe in der Inhaltsansicht
einer MultiPage-Seite zu ändern, geht's auch ohne API: ein Label in den Hintergrund legen, was größer als die Seite ist und dann
die Hintergrundfarbe vom Label per Code oder statisch setzen.

Gruß

Ich verstehe was du meinst - aber wenn ich ein Label einfüge verdeckt das Label alle Schaltflächen usw.
Kann man das irgendwie in den Hintergrund legen?

Da es aber auch so funktioniert und der Code ziemlich professionell aussieht lasse ich es erstmal so.

Aber ich würde die Register gerne auch in der jeweiligen Farbe anzeigen. Das geht mit dem Label nicht? Ich kann kein Label über die Register legen.
Top


Gehe zu:


Benutzer, die gerade dieses Thema anschauen: 1 Gast/Gäste