Rubrik: Controls · Sonstiges | VB-Versionen: VB6 | 15.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 Grimm | Bewertung: | Views: 25.575 |
ohne Homepage | System: Win9x, WinNT, Win2k, WinXP, Win7, Win8, Win10, Win11 | 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