vb@rchiv · Tipps & Tricks · Kreis aus Linien mit Access-Mitteln

Rubrik: Access | VB-Versionen: VBA

06.09.05

Kreis aus Linien mit Access-Mitteln Nachbildung der Circle-Methode für Access-Formulare
Autor: Richard Mittelstädt	Bewertung:	Views: 13.799
ohne Homepage	System: Win9x, WinNT, Win2k, WinXP, Win7, Win8, Win10, Win11	Beispielprojekt auf CD

Da die Access-Circle-Funktion nur in Berichten, nicht aber auf Formularen funktioniert, habe ich hierfür eine eigene Funktion entwickelt. Diese Funktion zeichnet in einem ACCESS-Formular / Berichts-Bereich einen Kreis / Kreisbogen aus Linien (Strichen) mit ACCESS-eigenen "Ur-Mitteln". Nützlich ist dies z. B. dann, wenn man den Hintergrund hinter dem Kreis variabel haben will, was mit einem Kreis-Bild nicht mehr geht. In solchen Fällen kann man sich mit der folgenden Funktion behelfen:

Option Compare Database
Option Explicit
 
Public Function KreisAusLinien( _
  F_BEREICH As Section, S_NAME As String, S_ZEIGEN As Boolean, _
  Optional S_ORDNEN As Boolean, Optional ORD_VONOBEN = 0.5 * 567, _
  Optional S_BREITE, Optional S_FARBE, Optional S_FARBE2, Optional S_LAENGE, _
  Optional M_OBEN, Optional M_LINKS, Optional K_RADIUS, _
  Optional A_WINKEL, Optional E_WINKEL)
  ' ***********************************************************************************
  ' Funktion zeichnet in einem ACCESS-Form./Berichts-Bereich einen Kreis/Kreisbogen
  ' aus Linien (Strichen) mit ACCESS-eigenen  "Ur-Mitteln" !
  ' (Die ACCESS-Circle-Funktion funktioniert leider nur in Berichten.)
  ' Wenn man z.B. den Hintergrund hinter dem Kreis variabel haben will, dann
  ' geht das z.B. mit einem Kreis-Bild nicht mehr. In solchen Fällen kann man sich
  ' mit der folgenden Funktion behelfen (wenn' s nicht zu viele Kreise sind...)
  ' **************************** Parameter ********************************************
  ' F_BEREICH  ' Formular-Bereich, in dem der Kreis gebildet werden soll. zB.:
  '            "Forms![For_KreisAusLinien].Section(acHeader)"
  ' S_NAME     ' Erste Zeichen Aller Strich-Control-Linien, zB. "Str__"
  ' S_ZEIGEN   ' True/False, NUR Alle Striche sichtbar/unsichtbar machen, nicht mehr.
  ' ************************* optionale Parameter *************************************
  ' S_ORDNEN   ' True/False
            ' - False  positioniert alle Striche zum Kreis entspr. der anderen Optionen...
            ' - True positioniert (ordnet) alle Striche so ("Ordnung" reinbringen) :
            '    -Höhe =  0.5 cm
            '    -Breite= 0.2 cm
            '    -Stärke= 3pt
            '    -Oben =  0,5 cm bzw.ORD_VONOBEN , +0,6 cm... +0,6 cm....(zeilenweise)
            '    -Links = 0.5 cm, 0.53 cm, 0.56 cm, ....  (10 Striche= 0.5 + 3cm...)
            '    -...-> 20 pro Zeile = 6 cm breit, bis es "knallt"....
            '   Diese Option ist auch gedacht, um Ordnung zu schaffen:
            '   Form im Entwurf öffnen, Funktion aufrufen und dann Form speichern.
  ' ORD_VONOBEN  Oben-Mass für den ersten Strich beim Ordnen
  ' 
  ' S_BREITE   ' Strichbreite 0...6
  ' S_FARBE    ' Strich-Farbe
  ' S_FARBE2   ' Strich-Farbe 2 (Alternierende Strich-Farben, zB. auf Bildern...)
  ' S_LAENGE   ' Strich-Länge
  ' M_OBEN     ' ACCESS-Oben-Abstand des Mittelpunktes
  ' M_LINKS    ' ACCESS-Links-Abstand des Mittelpunktes
  ' K_RADIUS   ' Kreisradius
  ' A_WINKEL   ' AnfangsWinkel für Kreisbogen   (Eingabe in Grad !!!)
  ' E_WINKEL   ' EndWinkel für Kreisbogen       (Eingabe in Grad !!!)
  ' *********************************************************************
  On Error GoTo ERR_01
  Dim i As Long, n As Long
  Dim CTL_FELD            ' Feld mit den Strich-Controls
  Dim CTL_ANZ As Long     ' Anzahl der Strich-Controls
  ReDim PROP_FELD(10, 0)  ' Properties-Feld für alle Strich-Controls
      ' 0-Spalte:  Strich-Control (nicht der Control-Name!, Form + Form-Bereich + Control)
    ' 1-Spalte:  Kreiswinkel für Strich-Control
    ' 2-Spalte:  y-Koordinate (Bezug: Kreismittelpunkt-> ACCESS-Oben-Wert)
    ' 3-Spalte:  x-Koordinate (Bezug: Kreismittelpunkt-> ACCESS-Links-Wert)
    ' 4-Spalte:  Strich-Höhe
    ' 5-Spalte:  Strich-Breite
  Dim W_DIFF  ' Winkel-Differenz zwischen den Strichen
  Dim O_ORD   ' Differenz der Oben-Werte zwischen "Zeilen" beim Ordnen der Strich-Controls
  O_ORD = 0.6 * 567
  Dim L_ORD   ' Differenz der Links-Werte zwischen "Spalten" beim Ordnen der Strich-Controls
  L_ORD = 0.3 * 567
  Dim z As Integer, s As Integer      ' Zeilen- und Spalten-Zähler beim Ordnen
  Dim O_ANF As Long, L_ANF As Long    ' Oben- und Links- Anfangswert beim Ordnen
  L_ANF = 0.5 * 567
  O_ANF = ORD_VONOBEN
  ' **** Liste mit Strich-Controls holen ************************************
  CTL_FELD = ControlListeStricheInForm(F_BEREICH, S_NAME)
  CTL_ANZ = UBound(CTL_FELD, 1)
 
  ' **** Striche im Formularbereich F_BEREICH zeigen ? **********************
  For i = 1 To CTL_ANZ
    CTL_FELD(i).Visible = S_ZEIGEN
  Next i
 
  ' **** Striche im Formularbereich F_BEREICH "ordnen" ? ********************
  If IsMissing(S_ORDNEN) Then Exit Function
  If S_ORDNEN = True Then   ' Striche im Formularbereich F_BEREICH "ordnen" !
    z = 0
    s = 0
    For i = 1 To CTL_ANZ
      CTL_FELD(i).Top = O_ANF + z * O_ORD
      CTL_FELD(i).Left = L_ANF + s * L_ORD
      CTL_FELD(i).Height = 0.5 * 567
      CTL_FELD(i).Width = 0.2 * 567
      CTL_FELD(i).BorderWidth = 3     ' Einheitliche Strich-Stärke
      CTL_FELD(i).LineSlant = True    ' Einheitliche ACCESS-Neigung
      CTL_FELD(i).BorderColor = 0     ' Einheitliche Farbe schwarz
      CTL_FELD(i).Visible = True      ' sichtbar !
      s = s + 1
      If s >= 20 Then  ' Zeile ist voll !
        s = 0        ' Wieder Spalte 1 (in neuer Zeile)
        z = z + 1    ' neue Zeile !
      End If
    Next i
  End If
 
  ' **** Striche-Stärke einstellen  ******************************************
  If Not IsMissing(S_BREITE) Then
    For i = 1 To CTL_ANZ
      CTL_FELD(i).BorderWidth = S_BREITE     ' Einheitliche Strich-Stärke
    Next i
  End If
 
  ' **** Strich-Farbe einstellen  *******************************************
  If IsMissing(S_FARBE) Then Exit Function
  If IsMissing(S_FARBE2) Then
    S_FARBE2 = S_FARBE  ' gleichfarbig
  End If
  For i = 1 To (CTL_ANZ)
    If i / 2 - Int(i / 2) > 0 Then
      CTL_FELD(i).BorderColor = S_FARBE
    Else
      CTL_FELD(i).BorderColor = S_FARBE2
    End If
  Next i
 
  ' **** Striche-Länge da ?  ******************************************
  If IsMissing(S_BREITE) Then Exit Function
  If IsMissing(S_LAENGE) Then Exit Function
  If IsMissing(M_OBEN) Then Exit Function
  If IsMissing(M_LINKS) Then Exit Function
  If IsMissing(K_RADIUS) Then Exit Function
  If IsMissing(A_WINKEL) Then Exit Function
  If IsMissing(E_WINKEL) Then Exit Function
 
  ReDim PROP_FELD(10, CTL_ANZ)
 
  ' *** Strich-Controls eintragen in 0-Spalte ********************
  For i = 1 To CTL_ANZ
    Set PROP_FELD(0, i) = CTL_FELD(i)
  Next i
 
  ' *** Pi berechnen *********************************************
  Dim pi
  pi = 4 * Atn(1)    '  ( tan(90 Grad = Pi/4) = 1  )
 
  ' *** Kreis-Winkel in 1-Spalte *********************************
  A_WINKEL = A_WINKEL * (pi / 180)    ' Umrechnen Grad--> Rad
  E_WINKEL = E_WINKEL * (pi / 180)
 
  ' *** Eingegebene Winkel "logisch berücksichtigen". (alle Strich-Linien optimal platzieren) ***
  If (E_WINKEL - A_WINKEL) >= 1.999999999 * pi Then
      ' geschl. Kreis, alle Striche ausnutzen! ' (letzte Strich-Pos. = 1 Intervall vor Endwinkel!)
    W_DIFF = (E_WINKEL - A_WINKEL) / (CTL_ANZ)
  Else
        ' offener Kreis (letzte Strich-Pos genau auf den End-Winkel!)
    W_DIFF = (E_WINKEL - A_WINKEL) / (CTL_ANZ - 1)
  End If
  For i = 1 To CTL_ANZ
    PROP_FELD(1, i) = A_WINKEL + (i - 1) * W_DIFF   ' Winkel-Einträge !
  Next i
 
  ' *** Y- und X- Koordinaten (von KreisMitte) in 2-, 3- Spalte ***
  For i = 1 To CTL_ANZ
    PROP_FELD(2, i) = K_RADIUS * Sin(PROP_FELD(1, i))   ' Y (vertikal)
    PROP_FELD(3, i) = K_RADIUS * Cos(PROP_FELD(1, i))   ' X (horiz.)
  Next i
 
  ' *** Y- und X- Koordinaten für ACCESS umrechnen in Oben- Links ***
  For i = 1 To CTL_ANZ
    PROP_FELD(2, i) = -PROP_FELD(2, i) + M_OBEN     ' Oben
 
    PROP_FELD(3, i) = PROP_FELD(3, i) + M_LINKS     ' Links
  Next i
 
  ' *** Höhe+Breite der Striche in 4-, 5- Spalte ****************************
  For i = 1 To CTL_ANZ
    PROP_FELD(4, i) = Abs(S_LAENGE * Cos(PROP_FELD(1, i)))   ' Y (vertikal)
    PROP_FELD(5, i) = Abs(S_LAENGE * Sin(PROP_FELD(1, i)))   ' X (horiz.)
  Next i
 
  ' *** Kreis mit Strich-Controls zeichnen **********************************
  For i = 1 To CTL_ANZ
    PROP_FELD(0, i).Height = PROP_FELD(4, i)    ' errechnete abs. Höhe
    PROP_FELD(0, i).Width = PROP_FELD(5, i)     ' errechnete abs. Breite
    ' ACCESS-Neigung einstellen:
    If Sgn(Sin(PROP_FELD(1, i)) * Cos(PROP_FELD(1, i))) > 0 Then
      PROP_FELD(0, i).LineSlant = False   ' ACCESS-Neigung für 1. + 3 Quadrand
    Else
      PROP_FELD(0, i).LineSlant = True    ' ACCESS-Neigung für 2. + 4 Quadrand
    End If
    ' Strich-Positionen aus eigener Höhe+Breite korrigieren für ACCESS (Oben+Links):
    PROP_FELD(0, i).Top = PROP_FELD(2, i) - (PROP_FELD(0, i).Height / 2)    ' Oben
    PROP_FELD(0, i).Left = PROP_FELD(3, i) - (PROP_FELD(0, i).Width / 2)    ' Links
  Next i
 
  Exit Function
 
  ERR_01:
  MsgBox "KreisAusLinien(...): " & Err.Number & "   " & Err.Description
End Function

Public Function TestKreisAusLinien()
  Call KreisAusLinien(Forms![For_KreisAusLinien2].Section(acHeader), _
    "St__", True, False, , 1, 255, , 0.15 * 567, 6 * 567, 7 * 567, 5 * 567, -90, 270)
  MsgBox "weiter mit Halbkreis -90 ... +90"
  Call KreisAusLinien(Forms![For_KreisAusLinien2].Section(acHeader), _
    "St__", True, False, , 1, 255, , 0.15 * 567, 6 * 567, 7 * 567, 5 * 567, -90, 90)
  MsgBox "weiter mit Halbkreis 90 ... 270"
  Call KreisAusLinien(Forms![For_KreisAusLinien2].Section(acHeader), _
    "St__", True, False, , 1, 255, , 0.15 * 567, 6 * 567, 7 * 567, 5 * 567, 90, 270)
End Function

Public Function TestKreisAusLinienFormularKopf(S_BREITE, S_FARBE, S_LAENGE, _
  M_OBEN, M_LINKS, K_RADIUS, A_WINKEL, E_WINKEL)
  Call KreisAusLinien(Forms![For_KreisAusLinien2].Section(acHeader), _
    "St__", True, False, 3 * 567, S_BREITE, S_FARBE, , S_LAENGE * 567, M_OBEN * 567, _
    M_LINKS * 567, K_RADIUS * 567, A_WINKEL, E_WINKEL)
End Function

Public Function TestKreisAusLinienVonBis(A_WINKEL As Double, E_WINKEL As Double)
  Call KreisAusLinien(Forms![For_KreisAusLinien2].Section(acHeader), _
    "St__", True, False, , 1, 255, , 0.15 * 567, 6 * 567, 7 * 567, 5 * 567, _
    A_WINKEL, E_WINKEL)
End Function

Public Function TestKreisAusLinienOrdnen()
  Call KreisAusLinien(Forms![For_KreisAusLinien2].Section(acHeader), "St__", _
    True, True, 5 * 567)
End Function

Public Function TestKreisAusLinienUnsichtbar()
  Call KreisAusLinien(Forms![For_KreisAusLinien2].Section(acHeader), "St__", False)
End Function

Public Function TestKreisAusLinienAlternierend_sw()
  Call KreisAusLinien(Forms![For_KreisAusLinien2].Section(acHeader), "St__", _
    True, False, , , 0, RGB(255, 255, 255))
End Function

Public Function ControlListeStricheInForm(F_BEREICH As Section, S_NAME As String)
  ' *********************************************************************
  ' Liste der Strich-Controls in Formular F_NAME ermitteln ausgeben
  ' F_BEREICH     	' Formular-Bereich!, in dem der Kreis gebildet werden soll.
  ' S_NAME     	' Erste Zeichen Aller Strich-Control-Namen, z.B. "Str__"
  On Error GoTo ERR_01
  Dim ctl1 As Control, i As Long
  Dim CTL_FELD() As Control
  For Each ctl1 In F_BEREICH.Controls
    If Left(ctl1.Name, Len(S_NAME)) = S_NAME Then
      i = i + 1
      ReDim Preserve CTL_FELD(i)
      Set CTL_FELD(i) = ctl1
    End If
  Next ctl1
  ControlListeStricheInForm = CTL_FELD
  Exit Function
 
ERR_01:
  MsgBox "ControlListeStricheInForm(...): " & Err.Number & "   " & Err.des
End Function

Public Function TestAnzahlStricheInForm()
  ' zeigt alle Strich-Control-Namen im Formular-Kopf
  Dim CTL_FELD
  CTL_FELD = ControlListeStricheInForm(Forms![For_KreisAusLinien].Section(acHeader), "St__")
  Dim i As Long, X
  For i = 1 To UBound(CTL_FELD, 1)
    X = X & CTL_FELD(i).Name & vbNewLine
  Next i
  MsgBox X
End Function