title image


Smiley Re: Graphikaufbau (Linien) beschleunigen
Hallo Martin,1.) erstelle ein leeres Formular.2.) zur Beschleunigung stellst Du AutoRedraw und ClipControls des Formulares auf False ein. Dadurch sind wir selber dafür zuständig, daß bei jedem Paint - Ereignis das Formular bemalt wird.3.) kopiere folgenden Code in Dein (noch leeres) Formular:Option Explicit ' Pen StylesPrivate Const PS_SOLID = 0Private Const PS_DASH = 1 ' -------Private Const PS_DOT = 2 ' .......Private Const PS_DASHDOT = 3 ' _._._._Private Const PS_DASHDOTDOT = 4 ' _.._.._Private Const PS_NULL = 5Private Const PS_INSIDEFRAME = 6Private Const PS_USERSTYLE = 7Private Const PS_ALTERNATE = 8Private Const PS_STYLE_MASK = &HF Private Const PS_ENDCAP_ROUND = &H0Private Const PS_ENDCAP_SQUARE = &H100Private Const PS_ENDCAP_FLAT = &H200Private Const PS_ENDCAP_MASK = &HF00 Private Const PS_JOIN_ROUND = &H0Private Const PS_JOIN_BEVEL = &H1000Private Const PS_JOIN_MITER = &H2000Private Const PS_JOIN_MASK = &HF000& Private Const PS_COSMETIC = &H0Private Const PS_GEOMETRIC = &H10000Private Const PS_TYPE_MASK = &HF0000 Private Type POINTAPI ' ein api-Punkt. x As Long y As LongEnd Type Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As LongPrivate Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As LongPrivate Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Private Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, lpPoint As POINTAPI) As LongPrivate Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long Private Sub Form_Paint() ApiDraw ' die Api-Version' NormalDraw ' die Normale Version zum VergleichEnd Sub Private Sub ApiDraw() Dim hNewPen As Long, hOldPen As Long ' Alter und neuer Stift. Dim lRetVal As Long ' allg. Rückgabewert. Dim udtPoint As POINTAPI Dim i As Integer ' ' Neuen Stift erstellen: ' hNewPen = CreatePen(PS_SOLID, 1, RGB(255, 0, 0)) If hNewPen = 0 Then MsgBox "Stift konnte nicht erstellt werden!", vbCritical Exit Sub End If ' ' Stift auswählen, der alte Stift wird in hOldPen gespeichert. ' hOldPen = SelectObject(Me.hdc, hNewPen) If hOldPen = 0 Then MsgBox "Stift kann nicht verwendet werden!", vbCritical Exit Sub End If ' ' Alle Maßeinheiten in Pixeln: ' Me.ScaleMode = vbPixels ' ' Wir zeichnen ein Karomuster mit der Linienbreite von einem Pixel und einem Pixel Abstand. ' ' 1.) horizontale Linien zeichnen: ' ' Zunächst bewegen wir den Stift in die linke obere Ecke. ' Der Rückgabewert (0 bei Fehler) interessiert uns nicht: wir werden das Ergebnis schon sehen! ' Die alte Position müssen wir uns eigentlich auch nicht merken. (letzter Parameter) lRetVal = MoveToEx(Me.hdc, Me.ScaleLeft, Me.ScaleTop, udtPoint) i = Me.ScaleTop Do While i ' Linie: lRetVal = LineTo(Me.hdc, Me.ScaleWidth, i) ' zwei Zeilen tiefer und wieder nach links: i = i + 2 lRetVal = MoveToEx(Me.hdc, Me.ScaleLeft, i, udtPoint) Loop ' ' 2.) vertikale Linien: ' ' Zunächst wieder nach links oben bewegen: lRetVal = MoveToEx(Me.hdc, Me.ScaleLeft, Me.ScaleTop, udtPoint) i = Me.ScaleTop Do While i ' Linie: lRetVal = LineTo(Me.hdc, i, Me.ScaleHeight) ' zwei Zeilen weiter nach rechts und wieder nach oben: i = i + 2 lRetVal = MoveToEx(Me.hdc, i, Me.ScaleTop, udtPoint) Loop ' ' Wir sind fertig mit der Malerei. Nun geht's ans Aufräumen. ' ' Alten Stift wieder auswählen: lRetVal = SelectObject(Me.hdc, hOldPen) ' "Neuen" Stift (Wird nun nicht mehr gebraucht) löschen und freigeben: lRetVal = DeleteObject(hNewPen)End Sub Private Sub NormalDraw() Dim i As Integer Me.ScaleMode = vbPixels For i = 0 To ScaleHeight Step 2 Me.Line (0, i)-Step(ScaleWidth, 0), vbRed Next For i = 0 To ScaleWidth Step 2 Me.Line (i, 0)-Step(0, ScaleHeight), vbRed NextEnd SubViel Erfolg!Thomas Prötzschcu
Thomas Prötzsch

geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: