vb@rchiv
VB Classic
VB.NET
ADO.NET
VBA
C#
Mails senden, abrufen und decodieren - ganz easy ;-)  
 vb@rchiv Quick-Search: Suche startenErweiterte Suche starten   Impressum  | Datenschutz  | vb@rchiv CD Vol.6  | Shop Copyright ©2000-2024
 
zurück
Rubrik: Access   |   VB-Versionen: VBA06.09.05
Kreis aus Linien mit Access-Mitteln

Nachbildung der Circle-Methode für Access-Formulare

Autor:   Richard MittelstädtBewertung:     [ Jetzt bewerten ]Views:  13.758 
ohne HomepageSystem:  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

Dieser Tipp wurde bereits 13.758 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-2024 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