vb@rchiv
VB Classic
VB.NET
ADO.NET
VBA
C#
Erstellen von dynamischen Kontextmen?s - wann immer Sie sie brauchen!  
 vb@rchiv Quick-Search: Suche startenErweiterte Suche starten   RSS-Feeds  | Newsletter  | Impressum  | Datenschutz  | vb@rchiv CD Vol.6  | Shop Copyright ©2000-2019
 
zurück
Rubrik: Controls · Sonstiges   |   VB-Versionen: VB615.02.08
Controls dynamisch zur Laufzeit erzeugen und verwenden

Einige kleine Code_Anweisungen um in eine leere VB.Form einige Steuerelemente zur Laufzeit hinzufügen.

Autor:   Norbert GrimmBewertung:     [ Jetzt bewerten ]Views:  21.665 
ohne HomepageSystem:  Win9x, WinNT, Win2k, WinXP, Vista, Win7, Win8, Win10 Beispielprojekt auf CD 

Dieser Tipp zeigt, wie sich dynamisch zur Laufzeit Steuerelemente auf eine leere VB.Form hinzufügen und verwenden lassen.

Erstellen Sie ein neues Projekt und fügen nachfolgenden Code in den Codeteil der Form ein:

' Einige kleine Code_Anweisungen um
' in eine leere VB.Form einige Steuerelemente
' zur Laufzeit hinzufügen.
'
' es können <Object> o. <VB.Controls>
' eingesetzt werden.
' Der Vorteil bei <VB.Controls> ist, dass man
' die Eigenschaften als Liste sieht.
'
' Ich glaube, das Programm spricht für sich.
 
Option Compare Binary
Option Explicit
 
Private Agent1                  As Object
Private HFlex1                  As Object
Private objInfo                 As Object
Private objBand1                As Object
Private lblBand1                As VB.Label
Private txtBox(1)               As VB.TextBox
 
' aktive Elemente
Private WithEvents LaufBand1    As VB.Timer
 
Private WithEvents cmdClose     As VB.CommandButton
Private WithEvents cmdBand      As VB.CommandButton
Private WithEvents cmdInfo      As VB.CommandButton
' Quelle: MOD_ASSI.bas
Private Function VBControlsX(ByRef Client As Object, ByRef VBCTL As Object, _
  ByVal vbTyp As Long, Optional ByVal ICTL As Variant) As Long
 
  On Error GoTo Err_VBControlsX
 
  Dim A       As Integer
  Dim B       As Integer
  Dim T       As Long
  Dim ctl     As Control
  Dim VCTL    As Variant
 
  If IsMissing(ICTL) Then ICTL = ""
 
  ' erzeuge <Namen>
  If ICTL = "" Then
    T = Timer
    ICTL = "VB" & T
    ' check auf Vorhandnsein
    ' Achtung: T-Differenz 1 sec.
    ' bei mehrfach Aufruf(en) der Funktion <Duplikat> möglich
    Do
      A = A + 1
      For Each ctl In Client.Controls
        If ctl.Name = ICTL Then
          ' verändere <Namen>
          ICTL = "VB" & T & A
          B = 0
          Exit For
        Else
          B = -1
        End If
      Next ctl
      ' If B = -1 Then Exit Do
    ' wiederhole bis <>
    Loop Until B
  Else
    For Each ctl In Client.Controls
      If ctl.Name = ICTL Then Exit Function
    Next ctl
  End If
 
  GoSub CheckTyp
  With Client.Controls
    Set VBCTL = .Add(VCTL, ICTL)
  End With
  VBControlsX = -1
 
Exit_VBControlsX:
  Exit Function
 
Err_VBControlsX:
  MsgBox Err & vbCr & Err.Description, , "VBX" & ctl.Name
  ' LogError Err, MODASSI & "VBControlsX", vbTyp
  Resume Exit_VBControlsX
 
CheckTyp:
  Select Case vbTyp
    Case 0
      VCTL = "VB.Label"
    Case 1
      VCTL = "VB.TextBox"
     Case 2
       VCTL = "VB.Frame"
     Case 3
       VCTL = "VB.CommandButton"
     Case 4
       VCTL = "VB.Image"
     Case 5
       VCTL = "VB.PictureBox"
     Case 6
       VCTL = "VB.ComboBox"
     Case 10
       VCTL = "VB.Timer"
     Case 11
       VCTL = "VB.Shape"
     Case 12
       VCTL = "VB.Line"
     Case 13
       VCTL = "VB.HScrollBar"
     Case 14
       VCTL = "VB.VScrollBar"
     Case 20
       VCTL = "MSFlexGridLib.MSFlexGrid"
     Case 21
       VCTL = "MSHierarchicalFlexGridLib.MSHFlexGrid"
     Case 22
       VCTL = "MSChart20Lib.MSChart"
     Case 30
       VCTL = "Agent.Control"
     Case Else
       Resume Exit_VBControlsX
  End Select
  Return
End Function
Private Function CreateVBCTL() As Integer
  On Error GoTo Err_CTL
 
  Dim H       As Long
  Dim VBX     As Long
  Dim T       As Long
  Dim W       As Long
  Dim VBObj   As Object
  Dim ICTL    As String
  Dim Path    As String
  Dim vInfo   As Variant
  Dim MIcon   As StdPicture
 
  ' überspringe, wenn kein Microsoft Agent
  ' Steuerelement muss in Komponente eingefügt sein, sonst Fehler
  GoTo NoAgent
 
  ' ->mein Pfad
  '        Path = gsServer & "\EXTRACTA" & ACTORS & "Genius.acg"
 
  ' eignen Pfad angeben
  ' eigner Actor
  ' z.B.
  ' Path = "C:\...\Genius.acg"
 
  ICTL = "Agent1"
  VBX = VBControlsX(Me, VBObj, 30, ICTL)
 
  Set Agent1 = VBObj
  With Agent1
    .Characters.Load "Genius", Path
    With .Characters("Genius")
      .Show
      .MoveTo 200, 300
      .Speak "Demo VB.Controls"  ' am besten in einem Timer_Ereignis
      ' .Think "???"             ' ständig aufrufen, mit verschiedenen
    End With
  End With
 
NoAgent:
  Set MIcon = Me.MouseIcon
  With Me
    H = .ScaleHeight
    W = .ScaleWidth
  End With
 
  ICTL = "lblBand1"
  VBX = VBControlsX(Me, VBObj, 0, ICTL)
  Set lblBand1 = VBObj
  With lblBand1
  ' Eignschaften (Properties) zuweisen
    .Alignment = 0          ' links
    .Appearance = 1         ' 3D
    .BackColor = &HC        ' Schwarz
    .BackStyle = 1          ' undurchsichtig
    .BorderStyle = 1        ' Fest einfach
    .Caption = "VB.Label"
    .FontName = "Tahoma"
    .FontBold = True
    .FontSize = 12
    .ForeColor = &HFF       ' vbRed 255
    .Height = 375
    .Width = W
    .Top = H - 1000
    .Visible = True
  End With
 
  ICTL = "Laufband1"
  VBX = VBControlsX(Me, VBObj, 10, ICTL)
  Set LaufBand1 = VBObj
  With LaufBand1
    .Interval = 1000
    ' .Enabled = True
  End With
 
  VBX = VBControlsX(Me, VBObj, 3, "cmdClose")
  Set cmdClose = VBObj
  With cmdClose
    .Caption = "&Beenden"
    .FontBold = True
    .MouseIcon = MIcon
    .MousePointer = vbCustom
    .ToolTipText = "Formular schließen..."
    .Visible = True
  End With
 
  VBX = VBControlsX(Me, VBObj, 3, "cmdBand")
  Set cmdBand = VBObj
  With cmdBand
    .Caption = "&Laufband"
    .FontBold = True
    .MouseIcon = MIcon
    .MousePointer = vbCustom
    .Tag = 0
    .ToolTipText = "umschalten Text für Laufband..."
    .Visible = True
  End With
 
  ' <Name> ist optional
  ' ICTL = "Text1"
  ICTL = ""
  VBX = VBControlsX(Me, VBObj, 1, ICTL)
  Set txtBox(1) = VBObj
  With txtBox(1)
    .BackColor = vbYellow
    .FontName = "Tahoma"
    .FontBold = True
    .ForeColor = vbBlue
    .ToolTipText = "VB.TextBox..."
    .Text = "TextBox(1)"
    .Width = 2000
    .Visible = True
  End With
 
  vInfo = " Info              " _
    & vbCr & vbCr & "  Norbert Grimm " _
    & vbCr & "  Datenverarbeitung, Produktionssteuerung" _
    & vbCr & "" _
    & vbCr & "  Mail: norbert.grimm@schwabe.de <geschäftlich>" _
    & vbCr & "            norbert.grimm@web.de         <privat>"
 
  VBX = VBControlsX(Me, VBObj, 0)
  Set objInfo = VBObj
  With objInfo
    .AutoSize = True
    .BackColor = vbYellow
    .BackStyle = 1
    .BorderStyle = 1
    .FontName = "Tahoma"
    .FontBold = True
    .ForeColor = vbBlue
    .ToolTipText = "VB.Label..."
    .Caption = vInfo
    .Left = 500
    .Width = 5000
    .Top = 500
    ' .Visible = True
  End With
 
  VBX = VBControlsX(Me, VBObj, 3, "Info1")
  Set cmdInfo = VBObj
  With cmdInfo
    .Caption = "&Info"
    .FontBold = True
    .MouseIcon = MIcon
    .MousePointer = vbCustom
    .Tag = 0
    .ToolTipText = "Info über Author..."
    .Visible = True
  End With
 
  GoTo NoFlex
  ' Steuerelement muss in Komponente eingefügt sein, sonst Fehler
  ' =in Toolbox_Auswahl
  ' erzeuge HFlex_Grid
  VBX = VBControlsX(Me, VBObj, 21, "HFlex1")
  Set HFlex1 = VBObj
  With HFlex1
    .Cols = 6
    .Left = 250
    .Width = 6000
    .Top = 1000
    .Visible = True
  End With
 
NoFlex:
 
Exit_CTL:
  Exit Function
 
Err_CTL:
  MsgBox Err & vbCr & Err.Description, , "CreateVBCTL"
  Resume Next
End Function
' Quelle: MOD_ASSI.bas
Private Function Null_X(varX As Variant, Optional varVal As Variant)
  On Error GoTo Err_Null_X
 
  If IsMissing(varVal) Then varVal = ""
  If IsNull(varX) Or Len(varX) = 0 Then
    Null_X = varVal
  Else
    Null_X = varX
  End If
  Exit Function
 
Err_Null_X:
  MsgBox Err & vbCr & Err.Description, "Null_X"
  Resume Next
End Function
Property Get MyAuthor() As String
  MyAuthor = " Norbert.Grimm"
End Property
Property Get MyCopyRight() As String
  MyCopyRight = "Copyright " & Chr(169) & " " & Year(Date) & MyAuthor
End Property
Private Sub cmdBand_Click()
  Dim vText   As Variant
 
  With cmdBand
    If .Tag = 0 Then
      .Tag = -1
      vText = "Demo für dyn. VB.Control von" & MyAuthor
    Else
      .Tag = 0
      vText = MyCopyRight
    End If
  End With
 
  lblBand1.Tag = vText
End Sub
Private Sub cmdClose_Click()
  Unload Me
End Sub
Private Sub cmdInfo_Click()
  ' check ob initialisiert...
  If Not objInfo Is Nothing Then
    objInfo.Visible = Not objInfo.Visible
  End If
End Sub
Private Sub Form_Load()
  On Error GoTo Err_Load
 
  CreateVBCTL
 
Exit_Load:
  Exit Sub
 
Err_Load:
  MsgBox Err & vbCr & Err.Description, , "Load"
  Resume Next
  ' Resume Exit_Load
End Sub
Private Sub Form_Resize()
  On Error GoTo Err_Resize
 
  Dim H   As Long
  Dim T   As Long
  Dim W   As Long
 
  With Me
    H = .ScaleHeight
    W = .ScaleWidth
  End With
 
  With lblBand1
    T = H - .Height
    T = T - 50
    .Top = T
    .Width = W
  End With
 
  With cmdClose
    .Left = 250
    T = H - .Height * 2
    .Top = T
  End With
 
  With cmdBand
    .Left = .Width * 2
    .Top = T
  End With
 
  With cmdInfo
    .Left = W - .Width - 200
    .Top = T
  End With
 
  ' check ob initialisiert...
  If Not txtBox(0) Is Nothing Then
    With txtBox(0)
      .Left = .Width * 2
      .Top = T
      .Top = .Top - .Height
    End With
  End If
 
  If Not txtBox(1) Is Nothing Then
    With txtBox(1)
      .Left = .Width * 2
      .Top = T
    End With
  End If
 
Exit_Resize:
  Exit Sub
 
Err_Resize:
  MsgBox Err & vbCr & Err.Description, , "Resize"
  Resume Next
  ' Resume Exit_Resize
End Sub
Private Sub LaufBand1_Timer()
  On Error GoTo Err_LB1
 
  Dim FS      As Long
  Dim AZ      As Long     ' ->Anzahl Zeichen->Band
  Dim L       As Long     ' ->Anzahl Zeichen->Caption
  Dim P       As Long     ' ->Zähler->Position
  Dim vCap    As Variant
  Dim vTg     As Variant
  Dim vTag    As Variant
 
  With LaufBand1
    vTg = .Tag
    If Null_X(vTg, 0) = 0 Then
      vTg = 1
      .Tag = vTg
    End If
    P = .Tag
  End With
 
  With lblBand1
    If .Alignment = 0 Then .Alignment = 1
    FS = .FontSize / 2
    AZ = .Width / (.FontSize * FS)
    If .Tag = "" Then .Tag = MyCopyRight  ' gsCopyRight
 
    vTag = .Tag & Space(P)
    L = Len(vTag)
 
    If L >= AZ Then
      P = 1
      .Caption = ""
    End If
    vCap = Mid(vTag, 1, P)
    .Caption = vCap
  End With
 
  LaufBand1.Tag = P + 1
 
Exit_LB1:
  Exit Sub
 
Err_LB1:
  MsgBox Err & vbCr & Err.Description, , "LaufBand1"
  ' in TestPhase
  Resume Next
  ' Resume Exit_LB1
End Sub

Dieser Tipp wurde bereits 21.665 mal aufgerufen.

Voriger Tipp   |   Zufälliger Tipp   |   Nächster Tipp

Über diesen Tipp im Forum diskutieren
Haben Sie Fragen oder Anregungen zu diesem Tipp, können Sie gerne mit anderen darüber in unserem Forum diskutieren.

Neue Diskussion eröffnen

nach obenzurück


Anzeige

Kauftipp Unser Dauerbrenner!Diesen und auch alle anderen Tipps & Tricks finden Sie auch auf unserer aktuellen vb@rchiv  Vol.6
(einschl. Beispielprojekt!)

Ein absolutes Muss - Geballtes Wissen aus mehr als 8 Jahren vb@rchiv!
- nahezu alle Tipps & Tricks und Workshops mit Beispielprojekten
- Symbol-Galerie mit mehr als 3.200 Icons im modernen Look
Weitere Infos - 4 Entwickler-Vollversionen (u.a. sevFTP für .NET), Online-Update-Funktion u.v.m.
 
   

Druckansicht Druckansicht Copyright ©2000-2019 vb@rchiv Dieter Otter
Alle Rechte vorbehalten.
Microsoft, Windows und Visual Basic sind entweder eingetragene Marken oder Marken der Microsoft Corporation in den USA und/oder anderen Ländern. Weitere auf dieser Homepage aufgeführten Produkt- und Firmennamen können geschützte Marken ihrer jeweiligen Inhaber sein.

Diese Seiten wurden optimiert für eine Bildschirmauflösung von mind. 1280x1024 Pixel