Tipp 0395 Kommentare auf einer UserForm anzeigen
Autor/Einsender:
Datum:
  Alexander Fross
29.04.2004
Entwicklungsumgebung:   Excel 2000
Leistungsfähiger und ausbaubarer Zellkommentator
In Excel gibt es die Möglichkeit mittels eines Zellenkommentars oder der Zellenvalidierung spezifischen Zellen Kommentare zu hinterlegen. Beide Varianten sind von den Möglichkeiten her stark eingeschränkt, was zum Beispiel die Art der Anzeige, die Formatierung, oder das Drucken des Kommentars betrifft.
Mit diesem Beispiel wird die Plattform für eine leistungsfähige Kommentaranzeige gewährleistet. Die Kommentare werden mittels einer UserForm und einer darauf befindlichen TextBox angezeigt, das die Möglichkeiten der Anzeige, Zugriff mit VBA usw. erhöht.
Der Basis-Code ist so aufgebaut, dass beim Aktivieren der Zelle automatisch die UserForm mit entsprechendem Kommentar neben der aktiven Zelle angezeigt wird. Da die UserForm nie den Fokus behält, wird die Navigation mit den Cursor-Tasten beeinflusst. Die UserForm kann manuell mit der Taste [ESC] beendet und mit [F4] angezeigt werden. Erhält eine Zelle den Fokus, der kein Kommentar zugewiesen ist, wird die UserForm automatisch geschlossen.
Erweiterungsmöglichkeiten bestehen nun darin, dass man der UserForm resp. der TextBox zum Beispiel ein Kontextmenü mit weiteren Funktionen wie Drucken, Löschen, Bearbeiten usw. zuweist.
Das Beispiel im Download ist sehr ausführlich kommentiert.
Code im Codebereich des Moduls modComments
 
Option Explicit

Public Const gc_WKS_Data_Name     As String = "Daten"
Public Const gc_WKS_Comments_Name As String = "Kommentare"

Public ga_DefaultPos(1) As Boolean

Sub EnableShortCutKeys(ByVal fEnable As Boolean)
  If fEnable Then
    Application.OnKey "{F4}", "UserFormComment_Show"
    Application.OnKey "{ESC}", "UserFormComment_Close"
  Else
    Application.OnKey "{F4}"
    Application.OnKey "{ESC}"
  End If
End Sub

Sub UserFormComment_Show()
  UserFormComment_Close
  frmComment.Show vbModeless
End Sub

Sub UserFormComment_Close()
  Dim frm As UserForm

  For Each frm In UserForms
    If frm Is frmComment Then
      Unload frm
      Exit For
    End If
  Next
End Sub
 
Code im Codebereich der UserForm frmComment
 
Option Explicit

Private Const PIX_Factor    As Double = 0.748

Private Const SPI_GETWORKAREA = 48

Private Const GWL_STYLE     As Long = -16
Private Const WS_CAPTION    As Long = &HC00000

Private Const HTCAPTION = 2
Private Const WM_NCLBUTTONDOWN = &HA1

Private m_hwndForm          As Long
Private m_sngFrmBarHeight   As Single

Private m_sngWorkAreaWidth  As Single
Private m_sngWorkAreaHeight As Single

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

Private Declare Function FindWindow Lib "user32" Alias _
      "FindWindowA" (ByVal lpClassName As String, ByVal _
      lpWindowName As String) As Long

Private Declare Function FindWindowEx Lib "user32" Alias _
      "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, _
      ByVal lpsz1 As String, ByVal lpsz2 As String) As Long

Private Declare Function GetWindowRect Lib "user32" (ByVal _
      hwnd As Long, lpRect As RECT) As Long

Private Declare Function SystemParametersInfo Lib "user32" Alias _
      "SystemParametersInfoA" (ByVal uAction As Long, ByVal _
      uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni _
      As Long) As Long

Private Declare Function GetWindowLong Lib "user32" Alias _
      "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex _
      As Long) As Long

Private Declare Function SetWindowLong Lib "user32" Alias _
      "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex _
      As Long, ByVal dwNewLong As Long) As Long

Private Declare Function DrawMenuBar Lib "user32" (ByVal _
      hwnd As Long) As Long

Private Declare Function SendMessage Lib "user32" Alias _
      "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, _
      ByVal wParam As Long, lParam As Any) As Long

Private Declare Function ReleaseCapture Lib "user32" () As Long

Private Declare Function SetFocusAPI Lib "user32" Alias _
      "SetFocus" (ByVal hwnd As Long) As Long

Private Sub UserForm_Initialize()
  Dim nStyle As Long

  m_sngFrmBarHeight = Me.Height - Me.InsideHeight

  m_hwndForm = FindWindow("ThunderDFrame", Me.Caption)

  nStyle = GetWindowLong(m_hwndForm, GWL_STYLE)
  nStyle = nStyle And Not WS_CAPTION
  SetWindowLong m_hwndForm, GWL_STYLE, nStyle
  DrawMenuBar m_hwndForm

  m_sngFrmBarHeight = _
      m_sngFrmBarHeight - ((Me.Height - Me.InsideHeight) / 2)

  Call GetTextAndFormSize(Me.txtComment)
  Call GetCoordinates
End Sub

Private Sub UserForm_Activate()
  SetFocusAPI FindWindow("XLMAIN", _
        ThisWorkbook.Application.Caption)
End Sub

Private Sub GetTextAndFormSize(ByVal TxtBox As MSForms.TextBox, _
                Optional ByVal minAbsWidth As Single = 77, _
                Optional ByVal minAbsHeight As Single = 15.75, _
                Optional ByVal maxRelWidth As Single = 0.3, _
                Optional ByVal maxRelHeight As Single = 0.3)

  Dim rct As RECT
  Dim wks As Worksheet

  SystemParametersInfo SPI_GETWORKAREA, 0, rct, 0
  m_sngWorkAreaWidth = (rct.Right - rct.Left) * PIX_Factor
  m_sngWorkAreaHeight = (rct.Bottom - rct.Top) * PIX_Factor

  TxtBox.Width = m_sngWorkAreaWidth * maxRelWidth

  Set wks = ThisWorkbook.Worksheets(gc_WKS_Comments_Name)
  With TxtBox
    .Value = wks.Range(ActiveCell.Address).Value
    .AutoSize = False
    .SelStart = 0
  End With
  Set wks = Nothing

  If TxtBox.Width < minAbsWidth Then TxtBox.Width = minAbsWidth
  If TxtBox.Height < minAbsHeight Then TxtBox.Height = minAbsHeight

  If TxtBox.Height > m_sngWorkAreaHeight * maxRelHeight Then
    TxtBox.Height = m_sngWorkAreaHeight * maxRelHeight
  End If

  Me.Width = TxtBox.Width + (Me.Width - Me.InsideWidth)
  Me.Height = TxtBox.Height + (Me.Height - Me.InsideHeight)
End Sub

Private Sub GetCoordinates()
  Dim hwnd              As Long
  Dim rctWndPos         As RECT

  Dim sngWndPosLeft     As Single
  Dim sngWndPosTop      As Single

  Dim sngZoom           As Single

  Dim asngPosX(1)       As Single
  Dim asngPosY(1)       As Single
  Dim asngCritPoint(1)  As Single

  Dim alngX(1)          As Long
  Dim alngY(1)          As Long

  hwnd = FindWindow("XLMAIN", vbNullString)
  If hwnd <> 0 Then
    hwnd = FindWindowEx(hwnd, 0&, "XLDESK", vbNullString)
    If hwnd <> 0 Then
      hwnd = FindWindowEx(hwnd, 0&, "EXCEL7", vbNullString)
      If hwnd = 0 Then Exit Sub
    End If
  End If

  Call GetWindowRect(hwnd, rctWndPos)

  sngWndPosLeft = rctWndPos.Left * PIX_Factor
  sngWndPosTop = rctWndPos.Top * PIX_Factor

  sngZoom = ActiveWindow.Zoom / 100

  asngPosX(0) = sngWndPosLeft + _
            (ExecuteExcel4Macro("GET.CELL(44)") * sngZoom) + _
            ((Me.Width - Me.InsideWidth) / 2)

  asngPosX(1) = sngWndPosLeft + _
            ((ExecuteExcel4Macro("GET.CELL(42)")) * sngZoom) - _
            Me.Width + ((Me.Width - Me.InsideWidth) / 2)

  asngPosY(0) = sngWndPosTop + _
            ((ExecuteExcel4Macro("GET.CELL(43)")) * sngZoom) + _
            m_sngFrmBarHeight

  asngPosY(1) = sngWndPosTop + _
            ((ExecuteExcel4Macro("GET.CELL(45)")) * sngZoom) + _
            m_sngFrmBarHeight - Me.Height

  asngCritPoint(0) = m_sngWorkAreaWidth - Me.Width
  asngCritPoint(1) = m_sngWorkAreaHeight - Me.Height

  alngX(0) = Abs(CBool(ga_DefaultPos(0)))
  alngX(1) = Abs(1 + CBool(ga_DefaultPos(0)))
  alngY(0) = Abs(CBool(ga_DefaultPos(1)))
  alngY(1) = Abs(1 + CBool(ga_DefaultPos(1)))

  Me.Left = GetPosition(asngPosX(alngX(0)), _
          asngPosX(alngX(1)), asngCritPoint(0), 0)
  Me.Top = GetPosition(asngPosY(alngY(0)), _
          asngPosY(alngY(1)), asngCritPoint(1), 1)
End Sub

Private Function GetPosition(ByVal Pos1 As Single, _
      ByVal Pos2 As Single, ByVal CritPoint As Single, _
      ByVal DefaultPos As Long) As Single

  Select Case True
    Case (Pos1 > 0 And Pos1 < CritPoint): GetPosition = Pos1
    Case (Pos2 > 0 And Pos2 < CritPoint): GetPosition = Pos2
    Case Else: GetPosition = CritPoint / 2
  End Select

  If GetPosition = Pos2 Then
    ga_DefaultPos(DefaultPos) = Not ga_DefaultPos(DefaultPos)
  End If
End Function

Private Sub txtComment_MouseDown(ByVal Button As Integer, _
    ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
  If m_hwndForm = 0 Then Exit Sub
  ReleaseCapture
  SendMessage m_hwndForm, WM_NCLBUTTONDOWN, HTCAPTION, 0

  SetFocusAPI FindWindow("XLMAIN", vbNullString)
End Sub
 
Code im Codebereich von DieseArbeitsmappe
 
Option Explicit

Private Sub Workbook_Activate()
  If ActiveSheet.Name = gc_WKS_Data_Name Then
    EnableShortCutKeys True
  End If
End Sub

Private Sub Workbook_Deactivate()
  EnableShortCutKeys False
  UserFormComment_Close
End Sub
 
Code im Codebereich der Tabelle Daten
 
Option Explicit

Private Sub Worksheet_Activate()
  EnableShortCutKeys True
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  Dim rng As Range

  Set rng = ThisWorkbook.Worksheets(gc_WKS_Comments_Name) _
          .Range(ActiveCell.Address)
  If Len(Trim$(rng.Value)) <> 0 Then
    UserFormComment_Show
  Else
    UserFormComment_Close
  End If
  Set rng = Nothing
End Sub

Private Sub Worksheet_Deactivate()
  EnableShortCutKeys False
  UserFormComment_Close
End Sub
 

Windows-Version
95
98/SE
ME
NT
2000
XP
Vista
Win 7
Excel-Version
95
97
2000
2002 (XP)
2003
2007
2010


Download  (31,1 kB) Downloads bisher: [ 1635 ]

Vorheriger Tipp Zum Seitenanfang Nächster Tipp

Startseite | Projekte | Tutorials | API-Referenz | VB-/VBA-Tipps | Komponenten | Bücherecke | VB/VBA-Forum | VB.Net-Forum | DirectX-Forum | Foren-Archiv | DirectX | VB.Net-Tipps | Chat | Spielplatz | Links | Suchen | Stichwortverzeichnis | Feedback | Impressum

Seite empfehlen Bug-Report
Letzte Aktualisierung: Montag, 3. September 2011