Die Community zu .NET und Classic VB.

Startseite / Tipps / VB.NET-Tipp 0017: InfoDialog

VB.NET-Tipp 0017: InfoDialog

 von Herfried Wagner

Schwierigkeitsgrad:

Framework-Version(en): .NET Framework 1.0, .NET Framework 1.1, .NET Framework 2.0, .NET Framework 3.0, .NET Framework 3.5

.NET-Version(en): Visual Basic 2002, Visual Basic 2003, Visual Basic 2005, Visual Basic 2008

Download: Download des Beispielprojektes [5,99 KB]

' Dieser Quellcode stammt von http://www.activevb.de
' und kann frei verwendet werden. Für eventuelle Schäden
' wird nicht gehaftet.

' Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
' Ansonsten viel Spaß und Erfolg mit diesem Source!

' Projektversion:   Visual Studio 2002/2003
' Option Strict:    An
' Option Explicit:  An
'
' Referenzen: 
'  - System
'  - System.Data
'  - System.Drawing
'  - System.Windows.Forms
'  - System.XML
'
' Imports: 
'  - Microsoft.VisualBasic
'  - System
'  - System.Collections
'  - System.Data
'  - System.Drawing
'  - System.Diagnostics
'  - System.Windows.Forms
'

' ##############################################################################
' ################################# FMain.vb ###################################
' ##############################################################################
Option Explicit On 
Option Strict On

Public Class FMain
    Inherits System.Windows.Forms.Form


#Region " Event handlers "
    Private Sub btnShellAbout_Click( _
      ByVal sender As System.Object, _
      ByVal e As System.EventArgs) _
      Handles btnShellAbout.Click
        ShellAbout( _
            Me.Handle.ToInt32, _
            "SampleApp#MyApp", _
            "This is an application.", _
            Me.Icon.Handle.ToInt32 _
        )
    End Sub

    Private Sub btnShellAboutEx_Click( _
      ByVal sender As System.Object, _
      ByVal e As System.EventArgs) _
      Handles btnShellAboutEx.Click
        ShellAboutEx( _
            Me.Handle.ToInt32, _
            Me.Icon.Handle.ToInt32, _
            "About SampleApp", _
            "SampleApp™", _
            "HirfSoft Corp.", _
            "Version 4.5 (Build 1286)", _
            "Copyright © 1999-2001 HirfSoft Corp.", _
            "Written by Herfried K. Wagner", _
            "Edition:    " & "Professional", _
            "Licensed to:  " & ControlChars.Tab & _
              "Pink Panther", _
            "Serial Number:" & ControlChars.Tab & _
            "A23766BD-34AD-22PD", _
            , _
            , _
            "Close" _
        )
    End Sub
#End Region
End Class
' ##############################################################################
' ################################ modMain.vb ##################################
' ##############################################################################
Option Explicit On 
Option Strict On

Public Module modMain

    '
    ' Haupteinstiegspunkt der Anwendung.
    '
    <STAThread()> _
    Public Sub Main()
        Dim frmMain As New FMain()
        frmMain.ShowDialog()
    End Sub
End Module
' ##############################################################################
' ############################ modShellAboutEx.vb ##############################
' ##############################################################################
'
' Note: This application was built for 
' demonstration purpose only. 
' Sometimes when this sample runs on a slow 
' machine you will see the original captions 
' of the labels in the about dialog.
' A better approach would be to install 
' a dialog hook to change the properties of the
' controls on the about window before it is shown.
'
' Dieses Beispiel funktioniert nur unter 
' Windows 2000 und Windows Millennium und Windows XP
' fehlerferi, da die Anzahl der Steuerelemente im 
' Info-Dialog der verschiedenen Windows-Versionen
' variiert. Daher wäre eine zusätzliche Abfrage 
' der Windows-Version erforderlich, auf die aber
' in diesem Beispiel verzichtet wurde. Das Problem 
' eines fehlenden STATIC-Controls unter Windows
' 2000 wurde über einen Check des Klassennamens 
' der "letzten" Controls behoben.
'
' Der "schöneren" Programmierung zuliebe sollte
' man ausserdem den Inhalt in eine eigene
' Klasse mit entsprechenden Eigenschaften und 
' Methoden packen.
'
Option Explicit On 
Option Strict On

Module modShellAboutEx
#Region " Delegate declarations "
    Private Delegate Sub TimerFuncDelegate( _
      ByVal lngWndID As Integer, _
      ByVal msg As Integer, _
      ByVal lngEventID As Integer, _
      ByVal lngSysTime As Integer)
    Private Delegate Function _
      EnumChildProcDelegate( _
      ByVal hWnd As Integer, _
      ByVal lParam As Integer) As Integer
#End Region

#Region " API declarations "
    Private Declare Function EnumChildWindows _
      Lib "user32.dll" (ByVal hwndParent As Integer, _
      ByVal lpEnumFunc As EnumChildProcDelegate, _
      ByVal lParam As Integer) As Integer
    Private Declare Function GetClassName _
      Lib "user32.dll" Alias "GetClassNameA" _
      (ByVal hwnd As Integer, ByVal lpClassName As String, _
      ByVal nMaxCount As Integer) As Integer
    Private Declare Function GetWindowText _
      Lib "user32.dll" Alias "GetWindowTextA" _
      (ByVal hwnd As Integer, _
      ByVal lpString As String, _
      ByVal cch As Integer) As Integer
    Private Declare Function SetWindowText _
      Lib "user32.dll" Alias "SetWindowTextA" _
      (ByVal hwnd As Integer, ByVal lpString As String) _
      As Integer
    Private Declare Function FindWindow _
      Lib "user32.dll" Alias "FindWindowA" _
      (ByVal lpClassName As String, _
      ByVal lpWindowName As String) _
      As Integer
    Private Declare Function CreateFont _
      Lib "gdi32.dll" Alias "CreateFontA" _
      (ByVal h As Integer, ByVal W As Integer, _
      ByVal E As Integer, _
      ByVal O As Integer, _
      ByVal W As Integer, _
      ByVal I As Integer, _
      ByVal u As Integer, _
      ByVal s As Integer, _
      ByVal C As Integer, _
      ByVal OP As Integer, _
      ByVal CP As Integer, _
      ByVal Q As Integer, _
      ByVal PAF As Integer, _
      ByVal F As String) As Integer
    Private Declare Function SendMessage _
      Lib "user32.dll" Alias "SendMessageA" _
      (ByVal hwnd As Integer, _
      ByVal wMsg As Integer, _
      ByVal wParam As Integer, _
      ByRef lParam As Integer) _
      As Integer
    Private Declare Function DeleteObject _
      Lib "gdi32.dll" (ByVal hObject As Integer) As Integer

    Private Const FW_BOLD As Integer = 700
    Private Const WM_SETFONT As Integer = &H30

    Public Declare Function ShellAbout _
      Lib "shell32.dll" Alias "ShellAboutA" _
      (ByVal hWnd As Integer, _
      ByVal szApp As String, _
      ByVal szOtherStuff As String, _
      ByVal hIcon As Integer) As Integer
#End Region

#Region " Control related stuff "

    ' Index of the static control in the about dialog.
    Private m_intIndex As Integer

    ' I don't know if the controls are enumerated 
    ' in the same order on other versions than Win2K and WinMe.
    Private Const STATIC_MS As Integer = 2
    Private Const STATIC_VERSION As Integer = 3
    Private Const STATIC_COPYRIGHT As Integer = 4
    Private Const STATIC_AUTHOR As Integer = 5
    Private Const STATIC_LICENSE As Integer = 6
    Private Const STATIC_LICENSEDFOR As Integer = 7
    Private Const STATIC_ORGANIZATION As Integer = 8
    Private Const STATIC_REALMEM As Integer = 10
    Private Const STATIC_MEMSIZE As Integer = 11
    Private Const DEFPUSHBUTTON_OK As Integer = 12
#End Region

#Region " Timer API support "
    ' Stuff used for the API timer.
    Private Declare Function SetTimer _
      Lib "user32.dll" (ByVal hWnd As Integer, _
      ByVal nIDEvent As Integer, _
      ByVal uElapse As Integer, _
      ByVal lpTimetFunc As TimerFuncDelegate) _
      As Integer
    Private Declare Function KillTimer _
      Lib "user32.dll" (ByVal hWnd As Integer, _
      ByVal nIDEvent As Integer) _
       As Integer
#End Region

#Region " Module-level variables "

    ' Variables needed to store the new captions.
    Private m_strWndTitle As String
    Private m_strAppTitle As String
    Private m_strCorporation As String
    Private m_strVersion As String
    Private m_strCopyright As String
    Private m_strAuthor As String
    Private m_strLicense As String
    Private m_strLicensedFor As String
    Private m_strOrganization As String
    Private m_strRealMem As String
    Private m_strMemSize As String
    Private m_strCaptionOK As String

    Private m_hFont As Integer
    ' Handle to the font object.
    Private m_hwndTimer As Integer
    Private m_intTimerID As Integer

    Public Const OriginalText As String = "%"
    ' If this constant is passed to our function,
    ' the original caption will be used.
    Private Const m_conTimerID As Integer = 12345
#End Region

#Region " Timer related functions "
    Private Sub TimerFunc(ByVal intWndID As Integer, _
      ByVal msg As Integer, _
      ByVal intEventID As Integer, _
      ByVal intSysTime As Integer)
        DeleteTimer()
        FireTimer()
    End Sub

    Public Sub DeleteTimer()
        If m_intTimerID <> 0 Then _
        KillTimer(m_hwndTimer, m_conTimerID)
    End Sub

    Public Sub CreateTimer(ByVal hWnd As Integer)
        m_intTimerID = SetTimer(hWnd, m_conTimerID, _
          1, AddressOf TimerFunc)
        m_hwndTimer = hWnd
    End Sub

    '
    ' We need a timer which runs in an other thread 
    ' because when calling the ShellAbout function the
    ' application will be blocked until the dialog is 
    ' closed. That's why we set a timer which fires
    ' some milliseconds after we call ShellAbout. 
    ' Then we wait until the dialog is shown in order to
    ' replace the original captions/font.
    '
    Private Sub FireTimer()
        Dim hWnd As Integer

        ' Wait until dialog window exists.
        Do
            hWnd = FindWindow(Nothing, "ABOUTDIALOG")
            System.Windows.Forms.Application.DoEvents()
        Loop While hWnd = 0

        ' Change the caption.
        Call SetWindowText(hWnd, m_strWndTitle)

        ' Get all child windows in the about dialog and
        ' change their captions.
        Call EnumChildWindows(hWnd, AddressOf EnumChildProc, 0)
    End Sub
#End Region

#Region " Control manipulation functions "
    Public Function EnumChildProc(ByVal hWnd As Integer, _
      ByVal lParam As Integer) As Integer
        m_intIndex = m_intIndex + 1
        ' Increment counter for control index.

        ' Modify current control.
        Dim s As String
        Dim b As Boolean
        Select Case m_intIndex
            Case STATIC_MS
                s = m_strCorporation
                m_hFont = CreateFont(13, 0, 1, 0, FW_BOLD, _
                  0, 0, 0, 0, 0, 0, 2, 0, "Times New Roman")
                SendMessage(hWnd, WM_SETFONT, m_hFont, 0)
                b = True
            Case STATIC_VERSION
                s = m_strVersion : b = True
            Case STATIC_COPYRIGHT
                s = m_strCopyright
                b = True
            Case STATIC_AUTHOR
                s = m_strAuthor
                b = True
            Case STATIC_LICENSE
                s = m_strLicense
                b = True
            Case STATIC_LICENSEDFOR
                s = m_strLicensedFor
                b = True
            Case STATIC_ORGANIZATION
                s = m_strOrganization
                b = True
            Case STATIC_REALMEM
                s = m_strRealMem
                b = True
            Case STATIC_MEMSIZE
                s = m_strMemSize
                b = True
            Case Is >= DEFPUSHBUTTON_OK
                s = Space(7)
                Call GetClassName(hWnd, s, 7)
                If Left(UCase(s), 6) = "BUTTON" Then
                    s = m_strCaptionOK
                    b = True
                End If
        End Select

        ' If we shouldn't use the original caption 
        ' then set the new text.
        If b And s <> OriginalText Then SetWindowText(hWnd, s)

        ' Continue enumerating.
        Return 1
    End Function

    '
    ' A little helper function that returns the window text.
    '
    Private Function GetWndText(ByVal hWnd As Integer) As String
        Dim s As String = Space(256)
        Dim n As Integer = GetWindowText(hWnd, s, Len(s))
        GetWndText = Left(s, n)
    End Function
#End Region

#Region " ShellAboutEx main function "
    '
    ' Our implementation of AboutBox, AboutBoxEx ;-)
    '
    ' WinXP: strLicense parameter must not contain a vbTab.
    '
    Public Function ShellAboutEx(ByRef hwndParent As Integer, _
      ByVal hIcon As Integer, _
      ByRef strWndTitle As String, _
      ByRef strAppTitle As String, _
      ByRef strCorporation As String, _
      ByRef strVersion As String, _
      ByRef strCopyright As String, _
      ByRef strAuthor As String, _
      ByRef strLicense As String, _
      ByRef strLicensedFor As String, _
      ByRef strOrganization As String, _
      Optional ByRef strRealMem As String _
        = OriginalText, _
      Optional ByRef strMemSize As String _
        = OriginalText, _
      Optional ByRef strCaptionOK As String _
          = OriginalText) As Integer
        m_strWndTitle = strWndTitle
        m_strAppTitle = strAppTitle
        m_strCorporation = strCorporation & " " & strAppTitle
        m_strVersion = strVersion
        m_strCopyright = strCopyright
        m_strAuthor = strAuthor
        m_strLicense = strLicense
        m_strLicensedFor = strLicensedFor
        m_strOrganization = strOrganization
        m_strRealMem = strRealMem
        m_strMemSize = strMemSize
        m_strCaptionOK = strCaptionOK
        m_intIndex = 0
        CreateTimer(hwndParent)
        ShellAboutEx = ShellAbout(hwndParent, "ABOUTDIALOG#", Nothing, hIcon)
        DeleteObject(m_hFont)
    End Function
#End Region
End Module

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 2 archivierten Kommentare ansehen möchten.
Diese stammen noch von der Zeit, als es noch keine direkte Forenunterstützung für Fragen und Kommentare zu einzelnen Artikeln gab.
Aus Gründen der Vollständigkeit können Sie sich die ausgeblendeten Kommentare zu diesem Artikel aber gerne weiterhin ansehen.