'gLCD-Modul für LC-Displays mit T6963C-Controller von Christof Rueß, www.hobbyelektronik.org
'Die Verwendung dieses Moduls ist kostenfrei, solange diese Zeilen erhalten bleiben.
'Fragen, Kritik und Anregungen an: chris at hobbyelektronik punkt org

'Anschlussbelegung für T6963C-Displays am ParallelPort:
'PC D-SUB-Stecker - Display
'  1 (Datastrobe) - 5 (Write)
'          2 (D0) - 7 (D0)
'          ...    - ...
'   14 (Autofeed) - 7 (CE)
'       16 (Init) - 8 (C/D)
'     17 (Select) - 6 (RD)
'     18-25 (GND) - 1 (GND)

'Deklaration für die Portansteuerung (auch für Win2k & WinXP)
Public Declare Function PortIn32 Lib "inpout32.dll" Alias "Inp32" (ByVal PortAddress As Integer) As Integer
Public Declare Sub PortOut32 Lib "inpout32.dll" Alias "Out32" (ByVal PortAddress As Integer, ByVal Value As Integer)

Wer es schneller mag, kann die dlportio verwenden:
'Public Declare Function PortIn32 Lib "dlportio.dll" Alias "DlPortReadPortUlong" (ByVal PortAddress As Integer) As Integer
'Public Declare Sub PortOut32 Lib "dlportio.dll" Alias "DlPortWritePortUlong" (ByVal Port As Long, ByVal Value As Long)


'Damit das Auslesen der Bilder für die selbstdefinierten Zeichen schneller geht, bediene ich mich dieser API.
Public Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal Y As Long) As Long
Public Declare Function SetPixel Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal Y As Long, ByVal crColor As Long) As Long

'Zum Testen der Übertragungsgeschwindigkeit notwendig
Public Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As Currency) As Long
Public Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As Currency) As Long

Const Writelo = 1 'Pin 1
Const Writehi = 0
Const CElo = 2 'Pin 14
Const CEhi = 0
Const CDlo = 0 'Pin 16
Const CDhi = 4
Const RDlo = 8 'Pin 17
Const RDhi = 0

Public Enum tDisplayMode
  m_OR = 0
  m_EXOR = 1
  m_AND = 3
End Enum

Private LcdPort As Long
Private Charset(0 To 255) As String
Private mDisplayPower As Boolean
Private mShowCursor As Boolean
Private mBlinkCursor As Boolean
Private mShowText As Boolean
Private mShowGraphic As Boolean
Private mDisplayMode As tDisplayMode
Private mExternalCG As Boolean
Private mCursorHeight As Long

'Hiermit wird der Port, an dem das LCD angschlossen ist festgelegt
Property Let Port(NewPort As Long)
LcdPort = NewPort
End Property

'Damit der Port auch gelesen werden kann, ist dies hier notwendig:
Property Get Port() As Long
Port = LcdPort
End Property

'Setzen, ob das Display invertiert werden soll
Property Let Inverted(NewInverted As Long)
LcdInverted = NewInverted
End Property

'Lesen, ob das Display invertiert ist
Property Get Inverted() As Long
Port = LcdInverted
End Property

'binären String in dezimalen Long umwandeln
Function BintoDez(ByVal Bin As String) As Long
  Dim x&, Y&
    Bin = Bin & String$(8 - Len(Bin), "0")
    For x = 1 To Len(Bin)
      If Mid$(Bin, x, 1) = "1" Then
        Y = Y + 2 ^ (8 - x)
      End If
    Next x
    BintoDez = Y
End Function

'dezimal -> binär
Function DeztoBin(ByVal Dez As Long) As String
  Dim x%
   If Dez >= 2 ^ 32 Then
     Call MsgBox("Zahl ist größer als 32 Bit")
     Exit Function
   End If
   Do
     If (Dez And 2 ^ x) Then
       DeztoBin = "1" & DeztoBin
     Else
       DeztoBin = "0" & DeztoBin
     End If
     x = x + 1
   Loop Until 2 ^ x > Dez
   DeztoBin = Format(DeztoBin, "00000000")
End Function

'Const Writelo = 1 'Pin 1
'Const Writehi = 0
'Const Celo = 2 'Pin 14
'Const Cehi = 0
'Const CDlo = 0 'Pin 16
'Const CDhi = 4
'Const RDlo = 8 'Pin 17
'Const RDhi = 0

Private Function OutLcd(ByVal LcdData As Long, ByVal IsCommand As Boolean)
Dim controlval As Long

If IsCommand = True Then
  controlval = CDhi
Else
  controlval = CDlo
End If
PortOut32 LcdPort, LcdData
'PortOut32 LcdPort + 2, controlval + Writehi + CEhi + RDhi '0
PortOut32 LcdPort + 2, controlval + Writehi + CElo + RDhi '2
PortOut32 LcdPort + 2, controlval + Writelo + CElo + RDhi '3
PortOut32 LcdPort + 2, controlval + Writehi + CElo + RDhi '2
'PortOut32 LcdPort + 2, CDlo + Writehi + CEhi + RDhi
'WaitforLCD
End Function
   
Private Function WaitforLCD()
Dim x As Long
PortOut32 LcdPort + 2, 32 + 4 + 2 + 0 'CD=1, CS=0, WR=1, RD = 1
PortOut32 LcdPort + 2, 32 + 4 + 2 + 8 'CD=1, CS=0, WR=1, RD = 0
For x = 0 To 2000
  If PortIn32(LcdPort) And 3 Then
    PortOut32 LcdPort + 2, 32 + 4 + 2 + 0
    Exit For
  End If
Next
Debug.Print x
PortOut32 LcdPort + 2, 0
End Function

'--- Display Mode ---
'Die einzelnen Variablen werden hier im Modul gespeichert und danach (über DisplayModeChanged) an den Controller geschickt

Property Let DisplayPower(NewPower As Boolean)
mDisplayPower = NewPower
DisplayModeChanged
End Property

Property Get DisplayPower() As Boolean
DisplayPower = mDisplayPower
End Property

Property Let ShowCursor(NewShowCursor As Boolean)
mShowCursor = NewShowCursor
DisplayModeChanged
End Property

Property Get ShowCursor() As Boolean
ShowCursor = mShowCursor
End Property

Property Let BlinkCursor(NewBlinkCursor As Boolean)
mBlinkCursor = NewBlinkCursor
DisplayModeChanged
End Property

Property Get BlinkCursor() As Boolean
BlinkCursor = mBlinkCursor
End Property

Property Let ShowText(NewShowText As Boolean)
mShowText = NewShowText
DisplayModeChanged
End Property

Property Get ShowText() As Boolean
mShowText = mShowText
End Property

Property Let ShowGraphic(NewShowGraphic As Boolean)
mShowGraphic = NewShowGraphic
DisplayModeChanged
End Property

Property Get ShowGraphic() As Boolean
ShowGraphic = mShowGraphic
End Property

'Hier steckt das eigentliche "Know-How". Die einzelnen Werte werden erfragt und dann in Temp addiert, welches dann ausgegeben wird.
Private Function DisplayModeChanged()
Dim Temp As Long
Temp = 144
If mDisplayPower = False Then
  OutLcd Temp, True
  Exit Function 'Wenn das Display ausgeschaltet sein soll, ist hier Schluss...
End If
If mShowCursor = True Then 'Wenn der Cursor angezeigt werden soll...
  If mBlinkCursor = True Then 'noch kurz überprüfen, ob er auch blinken soll
    Temp = Temp + 3
  Else
    Temp = Temp + 2
  End If
End If
If mShowText = True Then Temp = Temp + 4
If mShowGraphic = True Then Temp = Temp + 8
OutLcd Temp, True
End Function

'--- Mode Set ---
'Gleiches Spiel wie oben...

Property Let DisplayMode(NewDisplaymode As tDisplayMode)
mDisplayMode = NewDisplaymode
ModeSetChanged
End Property

Property Get DisplayMode() As tDisplayMode
DisplayMode = mDisplayMode
End Property

Property Let ExternalCG(NewExternalCG As Boolean)
mExternalCG = NewExternalCG
ModeSetChanged
End Property

Property Get ExternalCG() As Boolean
ExternalCG = mExternalCG
End Property

'Hier ist es noch ein bisschen weniger an Text.
'Der "Text Attribute Mode" wird noch nicht unterstützt, müsste ich noch mal machen.
Private Function ModeSetChanged()
Dim Temp As Long
Temp = 128
Temp = Temp + mDisplayMode
If mExternalCG = True Then Temp = Temp + 8
OutLcd Temp, True
End Function

'Cursorhöhe setzen. Vorher aber noch schauen, ob die Höhe sich auch zwischen 1 und 8 befindet
Property Let CursorHeight(NewCursorHeight As Long)
mCursorHeight = NewCursorHeight
If mCursorHeight > 8 Then mCursorHeight = 8
If mCursorHeight < 1 Then mCursorHeight = 1
OutLcd 159 + mCursorHeight, True
End Property

Property Get CursorHeight() As Long
CursorHeight = mCursorHeight
End Property

'Cursorposition setzen leicht gemacht.
'Hier muss man wenigstens
Function SetCursorPos(ByVal XPos As Long, ByVal YPos As Long)
OutLcd XPos - 1, False
OutLcd YPos - 1, False
OutLcd 33, True
End Function

'Das Display initialisieren. Eigentlich muss man nur die Bereiche für Grafik, Text und CG-RAM festlegen.
Public Function Init()
OutLcd 0, False
OutLcd 0, False
OutLcd 64, True 'Cursor Home Address auf &H0000

OutLcd 22, False
OutLcd 0, False
OutLcd 65, True 'Set Text Area auf 22 Spalten

OutLcd 0, False
OutLcd 2, False
OutLcd 66, True 'Set Graphic Home Address auf &H0200

OutLcd 22, False
OutLcd 0, False
OutLcd 67, True 'Set Graphic Area 22 Spalten

OutLcd 2, False
OutLcd 0, False
OutLcd 34, True 'Bereich für CG-RAM setzen
End Function

'Einige Character sind wieder an anderer Stelle als im ASCII-Zeichensatz, also müssen sie ersetzt werden.
Function ParseText(ByVal Text As String) As String
Dim x As Long
Dim Parsed As String
Dim Temp As String
For x = 1 To Len(Text)
  Select Case Mid(Text, x, 1)
    Case "Ç": Parsed = Chr(96)
    Case "ü": Parsed = Chr(97)
    Case "é": Parsed = Chr(98)
    Case "â": Parsed = Chr(99)
    Case "ä": Parsed = Chr(100)
    Case "à": Parsed = Chr(101)
    Case "å": Parsed = Chr(102)
    Case "ê": Parsed = Chr(104)
    Case "ë": Parsed = Chr(105)
    Case "è": Parsed = Chr(106)
    Case "ï": Parsed = Chr(107)
    Case "î": Parsed = Chr(108)
    Case "ì": Parsed = Chr(109)
    Case "Ä": Parsed = Chr(110)
    Case "Å": Parsed = Chr(111)
    Case "É": Parsed = Chr(112)
    Case "æ": Parsed = Chr(113)
    Case "Æ": Parsed = Chr(114)
    Case "ô": Parsed = Chr(115)
    Case "ö": Parsed = Chr(116)
    Case "ò": Parsed = Chr(117)
    Case "û": Parsed = Chr(118)
    Case "ù": Parsed = Chr(119)
    Case "ÿ": Parsed = Chr(120)
    Case "Ö": Parsed = Chr(121)
    Case "Ü": Parsed = Chr(122)
    Case "¢": Parsed = Chr(123)
    Case "£": Parsed = Chr(124)
    Case "¥": Parsed = Chr(125)
    Case "ƒ": Parsed = Chr(127)
    Case "§": Parsed = "?"
    Case Else: Parsed = Mid(Text, x, 1)
  End Select
Temp = Temp & Parsed
Next
ParseText = Temp
End Function

'Text als "richtigen Text" an das Display auf die gegebene Position schreiben
Function WriteText(ByVal LcdText As String, ByVal XPos As Long, ByVal YPos As Long)
Dim x  As Long
LcdText = ParseText(LcdText)
OutLcd (XPos Mod 22) - 1 + (YPos - 1) * 22, False
OutLcd 0, False
OutLcd 36, True 'Pointer auf Text legen
For x = 1 To Len(LcdText)
  OutLcd Asc(Mid(LcdText, x, 1)) - 32, False
  OutLcd 192, True 'Text übergeben
Next
End Function

'Den Text auf dem Display löschen. Einfach gesagt, alles durch Leerzeichen ersetzen ;)
Function ClearText()
Dim x  As Long
OutLcd 0, False
OutLcd 0, False
OutLcd 36, True 'Pointer auf Text legen
For x = 1 To 22 * 8
  OutLcd 0, False
  OutLcd 192, True 'Text übergeben
Next
End Function

'Den Grafikbereich auf dem Display löschen. Im Prinzip ähnlich wie ClearText
Function ClearPic()
Dim x As Long
OutLcd 0, False
OutLcd 2, False
OutLcd 36, True 'Adresse auf Grafik setzen
For x = 0 To 1407
  OutLcd 0, False
  OutLcd 192, True 'Daten schreiben und Pointer vergrößern
Next
End Function

'Das Display "vollrauschen". Sehr ähnlich zu Clearpic
Function ShowNoise()
Dim x As Long
Randomize
OutLcd 0, False
OutLcd 2, False
OutLcd 36, True 'Adresse auf Grafik setzen
For x = 0 To 1407
  OutLcd Rnd * 63, False
  OutLcd 192, True 'Daten schreiben und Pointer vergrößern
Next
End Function

'Bild auf das Display übertragen
Function WritePic(ByVal LcdPicture As PictureBox)
Dim Y As Long
Dim StrRev As Boolean
Dim OldScaleMode As ScaleModeConstants
OldScaleMode = LcdPicture.ScaleMode 'Scalemode merken
LcdPicture.ScaleMode = 3 'Scalemode auf Pixel stellen
OutLcd 0, False
OutLcd 2, False
OutLcd 36, True
For Y = 0 To 63
  WritePicLine LcdPicture, Y
Next
LcdPicture.ScaleMode = OldScaleMode 'Scalemode zurücksetzen
End Function

'Zeichnen der angegeben Zeile des Displays (nur intern)
Private Function WritePicLine(ByVal LcdPicture As PictureBox, ByVal Line As Long)
Dim Temp As Long
Dim Xval, x
For Xval = 0 To 21
  Temp = 0
  For x = 0 To 5
    If GetPixel(LcdPicture.hDC, Xval * 6 + x, Line) < 8388607 Then
      Temp = Temp + 2 ^ (5 - x)
    End If
  Next x
  OutLcd Temp, False
  OutLcd 192, True
Next Xval
End Function

'Initialisiert die benutzerdefinierte Schriftart. Momentan beträgt die maximale Zeichenhöhe 8 Pixel. Die Breite ist beliebig.
'Das Dateiformat ist sehr Simpel aufgebaut:
'Die ersten drei Zahlen stehen für den ASCII-Code des Zeichens. Für A wäre dies 065.
'Die nachfolgenden Nummern beschreiben das Symbol. Jede dreier-Gruppe beschreibt eine des Symbols. Vorhergehende Nullstellen müssen als 0 geschrieben werden (32 -> 032)
'Die erste Spalte für A wäre 01111110 -> 126, die zweite 10010000 -> 144, ...
'Der gesamte Buchstabe "A" sieht wie folgt aus:
'065126144144144126
' A  0  1  1  1  0
'    1  0  0  0  1
'    1  0  0  0  1
'    1  1  1  1  1
'    1  0  0  0  1
'    1  0  0  0  1
'    1  0  0  0  1
'    0  0  0  0  0
Function InitGraphicFont(ByVal FontFile As String) As Boolean
'On Error GoTo Fehler
Dim FHandle As Long
Dim Temp As String
FHandle = FreeFile
Open FontFile For Input As FHandle
  Do While EOF(FHandle) = False
    Input #FHandle, Temp
      If Len(Trim(Temp)) <> 0 And Left(Trim(Temp), 1) <> "#" Then
        Charset(Mid(Temp, 1, 3)) = Right(Temp, Len(Temp) - 3)
      End If
  Loop
Close FHandle
InitGraphicFont = True
Exit Function
Fehler:
InitGraphicFont = False
End Function

'Den angegebenen Text der initialisierten Schriftart auf eine PictureBox mit hDc schreiben.
Function WriteGraphicText(ByVal DstPicture As PictureBox, ByVal LcdText As String, ByVal StartX As Long, ByVal StartY As Long, Optional ByVal FontTransparent As Boolean = False, Optional ByVal FontNegative As Boolean = False) As Boolean
On Error GoTo Fehler
Dim x, Y, TxtPos, ChrPos, clrActive, clrInactive As Long
Dim CurrChar, CurrCharCol As String
Dim OldScaleMode As ScaleModeConstants
OldScaleMode = DstPicture.ScaleMode 'Scalemode merken
DstPicture.ScaleMode = 3 'Scalemode auf Pixel stellen
x = StartX
If FontNegative = False Then 'Wenn die Schrift nicht negativ sein soll, ...
  clrActive = 0 '... soll die dunkle Farbe Schwarz sein...
  clrInactive = 16777215 '... und die helle Farbe weiß
Else 'andernfalls
  clrActive = 16777215 'umgekehrt!
  clrInactive = 0
End If
For TxtPos = 1 To Len(LcdText) 'den ganzen Text "abklappern"
  CurrChar = Charset(Asc(Mid(LcdText, TxtPos, 1))) 'aktuelles Zeichen in die Variable setzen (Übersichtlicher/spart Zeit)
  For ChrPos = 1 To Fix(Len(CurrChar) / 3) 'jede Spalte ist 3 Zeichen lang
    CurrCharCol = DeztoBin(Mid(CurrChar, ChrPos * 3 - 2, 3)) 'die noch als dezimale Spalte in Binärwert umwandeln
    For Y = 1 To 8 'die einzelnen Bits abfragen
      If Mid(CurrCharCol, Y, 1) = "1" Then 'wenn das Bit 1 ist, soll...
        SetPixel DstPicture.hDC, x, StartY - 1 + Y, clrActive 'die das Bit aktiv dargestellt werden
      Else 'andernfalls...
        If FontTransparent = False Then '... und wenn die Schrift _nicht_ transpartent dargestellt werden soll, ...
          SetPixel DstPicture.hDC, x, StartY - 1 + Y, clrInactive '...soll das Bit inaktiv dargestellt werden
        End If
      End If
    Next Y
    x = x + 1 'die X-Koordinate 1 weiter nach rechts setzen
    If FontTransparent = False And TxtPos < Len(LcdText) Then 'Wenn die Schrift _nicht_ transpartent dargestellt werden soll, ...
      For Y = 1 To 8
        SetPixel DstPicture.hDC, x, StartY - 1 + Y, clrInactive 'soll eine ganze Spalte mit der inaktiven Farbe eingefügt werden
      Next Y
    End If
  Next ChrPos
  x = x + 1 'die X-Koordinate 1 weiter nach rechts setzen (Platz zwischen den Buchstaben)
Next TxtPos
DstPicture.ScaleMode = OldScaleMode 'Scalemode zurücksetzen
DstPicture.Refresh
WriteGraphicText = True
Exit Function
Fehler:
DstPicture.ScaleMode = OldScaleMode 'Scalemode zurücksetzen
WriteGraphicText = False
End Function

'Berechnen der Textlänge in Pixeln anhand der geladenen Schriftart und dem gewünschten Text
Function GraphicTextLength(ByVal LcdText As String) As Long
Dim x, TxtLen
TxtLen = 0
For x = 1 To Len(LcdText)
  TxtLen = TxtLen + Fix(Len(Charset(Asc(Mid(LcdText, x, 1)))) / 3) ' + 1
Next
TxtLen = TxtLen + Len(LcdText) - 1
If TxtLen = -1 Then TxtLen = 0

GraphicTextLength = TxtLen
End Function

'Testet die Übertragungsgeschwindigkeit eines kompletten Displayinhaltes an das Display
'Die Ausgabe erfolgt in ms
Function TestLcdSpeed() As Currency
Dim x As Long
Dim PerfFrequ As Currency
Dim PerfCntA As Currency
Dim PerfCntB As Currency
Dim PerfCntC As Currency
Dim PerfCntAvl As Long
PerfCntAvl = QueryPerformanceFrequency(PerfFrequ) '"Kalibriert" die Uhr
QueryPerformanceCounter PerfCntA 'den Startwert für den Counter in PerfCntA schreiben
ShowNoise 'Zum Testen der Geschwindigkeit wird das Display "verrauscht"
For x = 1 To 8
WriteText "Geschwindigkeitstest ", 1, x
Next
QueryPerformanceCounter PerfCntB 'den Endwert für den Counter in PerfCntB schreiben
TestLcdSpeed = CDbl((PerfCntB - PerfCntA) / PerfFrequ) * 1000
End Function