ABOUT Visual Basic Programmieren Programmierung Download Downloads Tips & Tricks Tipps & Tricks Know-How Praxis VB VBA Visual Basic for Applications VBS VBScript Scripting Windows ActiveX COM OLE API ComputerPC Microsoft Office Microsoft Office 97 Office 2000 Access Word Winword Excel Outlook Addins ASP Active Server Pages COMAddIns ActiveX-Controls OCX UserControl UserDocument Komponenten DLL EXE
Diese Seite wurde zuletzt aktualisiert am 30.11.1999

Diese Seite wurde zuletzt aktualisiert am 30.11.1999
Aktuell im ABOUT Visual Basic-MagazinGrundlagenwissen und TechnologienKnow How, Tipps und Tricks rund um Visual BasicAddIns für die Visual Basic-IDE und die VBA-IDEVBA-Programmierung in MS-Office und anderen AnwendungenScripting-Praxis für den Windows Scripting Host und das Scripting-ControlTools, Komponenten und Dienstleistungen des MarktesRessourcen für Programmierer (Bücher, Job-Börse)Dies&Das...

Themen und Stichwörter im ABOUT Visual Basic-Magazin
Code, Beispiele, Komponenten, Tools im Überblick, Shareware, Freeware
Ihre Service-Seite, Termine, Job-Börse
Melden Sie sich an, um in den vollen Genuss des ABOUT Visual Basic-Magazins zu kommen!
Informationen zur AVB-Web-Site, Kontakt und Impressum

Zurück...

Zurück...


Anzeige

Code des Controls BackPic

Option Explicit

Private Type RECT
  Left As Long
  Top As Long
  Right As Long
  Bottom As Long
End Type

Private Declare Function GetClientRect Lib "user32" _
 (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function GetWindow Lib "user32" _
 (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function InvalidateRect Lib "user32" _
 (ByVal hwnd As Long, lpRect As RECT, ByVal bErase As Long) _
 As Long

Private mClientWnd As Long
Private mForm As Form

Private WithEvents eMDIForm As MDIForm
Attribute eMDIForm.VB_VarHelpID = -1
Private WithEvents eForm As Form
Attribute eForm.VB_VarHelpID = -1

Public Enum bpStyleConstants
  bpCenter
  bpAdjust
  bpTile
  bpStretch
End Enum

Private pEnabled As Boolean
Private pPicture As StdPicture
Private pStyle As bpStyleConstants

Public Property Get Enabled() As Boolean
  Enabled = pEnabled
End Property

Public Property Let Enabled(ByVal New_Enabled As Boolean)
  If pEnabled <> New_Enabled Then
    pEnabled = New_Enabled
    If Ambient.UserMode Then
      zRefresh
    End If
  End If
  PropertyChanged "Enabled"
End Property

Public Property Get Picture() As StdPicture
  Set Picture = pPicture
End Property

Public Property Let Picture(New_Picture As StdPicture)
  zSetPicture New_Picture
End Property

Public Property Set Picture(New_Picture As StdPicture)
  zSetPicture New_Picture
End Property

Private Sub zSetPicture(New_Picture As StdPicture)
  Set pPicture = New_Picture
  If Ambient.UserMode Then
    zRefresh
  Else
    Set UserControl.Picture = pPicture
    UserControl_Resize
  End If
  PropertyChanged "Picture"
End Sub

Public Property Get Style() As bpStyleConstants
  Style = pStyle
End Property

Public Property Let Style(ByVal New_Style As bpStyleConstants)
  Select Case New_Style
    Case pStyle
    Case bpCenter To bpStretch
      pStyle = New_Style
      If Ambient.UserMode Then
        zRefresh
      End If
    Case Else
      Err.Raise 380
  End Select
  PropertyChanged "Style"
End Property

Public Sub Refresh()
  zRefresh
End Sub

Private Sub eForm_Resize()
  If eForm.WindowState <> vbMinimized Then
    zRefresh
  End If
End Sub

Private Sub eMDIForm_Resize()
  If eMDIForm.WindowState <> vbMinimized Then
    zRefresh
  End If
End Sub

Private Sub UserControl_InitProperties()
  Dim nControl As Control
  
  pEnabled = True
  With UserControl
    .BackColor = Ambient.BackColor
    If TypeOf .Parent Is MDIForm Then
    ElseIf TypeOf UserControl.Parent Is Form Then
    Else
      Err.Raise vbObjectError + 10000, Ambient.DisplayName, _
       "BackPic kann nur auf Forms und MDIForms in Visual Basic " & _
       "verwendet werden!"
      Exit Sub
    End If
    With .Parent
      For Each nControl In .Controls
        If nControl.Name <> Ambient.DisplayName Then
          If TypeName(nControl) = TypeName(Me) Then
            Err.Raise vbObjectError + 10001, Ambient.DisplayName, _
             "Es kann nur 1 BackPic-Steuerelement auf einem Form " & _
             "platziert werden!"
            Exit Sub
          End If
        End If
      Next
      If Not zIsNothing(.Picture) Then
        zSetPicture .Picture
        If MsgBox("Picture-Objekt des Forms löschen?", _
         vbYesNo Or vbDefaultButton2 Or vbQuestion, _
         Ambient.DisplayName) = vbYes Then
          Set .Picture = Nothing
        End If
      End If
    End With
  End With
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
  Const GW_CHILD = 5
  
  If Ambient.UserMode Then
    shp.Visible = False
    If TypeOf UserControl.Parent Is MDIForm Then
      Set eMDIForm = UserControl.Parent
      Set mForm = eMDIForm
      mClientWnd = GetWindow(mForm.hwnd, GW_CHILD)
    ElseIf TypeOf UserControl.Parent Is Form Then
      Set eForm = UserControl.Parent
      Set mForm = eForm
    Else
      Err.Raise vbObjectError + 10000, Ambient.DisplayName, _
       "BackPic kann nur auf Forms und MDIForms in Visual Basic " & _
       "verwendet werden!"
    End If
  Else
    Set UserControl.Picture = pPicture
  End If
  Me.Enabled = PropBag.ReadProperty("Enabled", True)
  pStyle = PropBag.ReadProperty("Style", bpCenter)
  zSetPicture PropBag.ReadProperty("Picture", Nothing)
End Sub

Private Sub UserControl_Resize()
  Dim nPicWidth As Single
  Dim nPicHeight As Single
  
  Static sInProc As Boolean

  If sInProc Then
    Exit Sub
  Else
    sInProc = True
  End If
  If Not Ambient.UserMode Then
    With UserControl
      If Not zIsNothing(pPicture) Then
        nPicWidth = .ScaleX(pPicture.Width, vbHimetric, vbTwips)
        nPicHeight = .ScaleY(pPicture.Height, vbHimetric, vbTwips)
        If .Width > nPicWidth Then
          .Width = nPicWidth
        End If
        If .Height > nPicHeight Then
          .Height = nPicHeight
        End If
      End If
      shp.Move 0, 0, .ScaleWidth, .ScaleHeight
    End With
  End If
  sInProc = False
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
  PropBag.WriteProperty "Enabled", pEnabled, True
  PropBag.WriteProperty "Picture", pPicture, Nothing
  PropBag.WriteProperty "Style", pStyle, bpCenter
End Sub

Private Function zIsNothing(Obj As Object, _
 Optional ByVal CheckHandleIfPicture As Boolean = True) As Boolean
  Dim nIsNothing As Boolean
  
  nIsNothing = CBool(Obj Is Nothing)
  If Not nIsNothing Then
  If CheckHandleIfPicture Then
    If TypeOf Obj Is StdPicture Then
    nIsNothing = Not CBool(Obj.Handle)
    End If
  End If
  End If
  zIsNothing = nIsNothing
End Function

Private Sub zRefresh()
  Dim nRect As RECT
  Dim nPicWidth As Single
  Dim nPicHeight As Single
  Dim nDestScale As Single
  Dim nImageScale As Single
  Dim nLeft As Single
  Dim nTop As Single
  Dim nRow As Long
  Dim nCol As Long
  Dim nScaleHeight As Single
  Dim nScaleWidth As Single
  
  If pEnabled Then
    If mForm Is Nothing Then
      Exit Sub
    End If
    If zIsNothing(pPicture) Then
      Exit Sub
    End If
    With mForm
      UserControl.Size .ScaleWidth, .ScaleHeight
    End With
    With UserControl
      nPicWidth = .ScaleX(pPicture.Width, vbHimetric, vbPixels)
      nPicHeight = .ScaleY(pPicture.Height, vbHimetric, vbPixels)
      nScaleWidth = .ScaleWidth
      nScaleHeight = .ScaleHeight
      .BackColor = mForm.BackColor
      .AutoRedraw = True
      .Cls
      Select Case pStyle
        Case bpCenter
          .PaintPicture pPicture, (nScaleWidth - nPicWidth) \ 2, _
           (nScaleHeight - nPicHeight) \ 2
        Case bpAdjust
          If CBool(nScaleWidth > 0) And CBool(nScaleHeight > 0) Then
            nDestScale = nScaleWidth / nScaleHeight
            nImageScale = nPicWidth / nPicHeight
            If nDestScale >= nImageScale Then
              nPicWidth = nPicWidth / (nPicHeight / nScaleHeight)
              nPicHeight = nScaleHeight
              nLeft = (nScaleWidth - nPicWidth) \ 2
            Else
              nPicHeight = nPicHeight / (nPicWidth / nScaleWidth)
              nPicWidth = nScaleWidth
              nTop = (nScaleHeight - nPicHeight) \ 2
            End If
            .PaintPicture pPicture, nLeft, nTop, nPicWidth, nPicHeight
          End If
        Case bpTile
          Do While nTop < nScaleHeight
            Do While nLeft < nScaleWidth
              .PaintPicture pPicture, nLeft, nTop
              nLeft = nLeft + nPicWidth
            Loop
            nLeft = 0
            nTop = nTop + nPicHeight
          Loop
        Case bpStretch
          .PaintPicture pPicture, 0, 0, .ScaleWidth, .ScaleHeight
      End Select
      Set mForm.Picture = .Image
      .AutoRedraw = False
    End With
  Else
    Set mForm.Picture = Nothing
  End If
  If TypeOf mForm Is MDIForm Then
    GetClientRect mClientWnd, nRect
    InvalidateRect mClientWnd, nRect, True
  End If
End Sub

Zurück zu "Hintergründiges für (MDI-)Forms" Zurück zum Text   


Komponenten-Übersicht

Zum Seitenanfang

Copyright © 1999 - 2017 Harald M. Genauck, ip-pro gmbh  /  Impressum

Zum Seitenanfang

Zurück...

Zurück...

Download Internet Explorer