Option Explicit

'gLCD-Ansteuerung von Christof Rueß, www.hobby-elektronik.de.vu
'Die Verwendung dieses Moduls ist kostenfrei, solange diese Zeilen erhalten bleiben.
'Fragen, Kritik und Anregungen an: hobbyelektronik@gmx.net

'Anschlussbelegung des Displays am ParallelPort (Sub-D):
'Vdd mit zwei Dioden an Pin 6 und 7 (Anoden der Dioden jeweils an Pin 6/7, Kathoden gemeinsam an Vdd)
'SCL an Pin 2
'SDA an Pin 3
'D/C an Pin 4
'RES an Pin 5
'GND an Pin 18-25
'SCE an Pin 18-25
'Vout mit 1µF-Elko (!) an Pin 18-25 (- an Pin 18-25)

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

'Falls QueryPerformance* nicht verfügbar ist, wird das normale Sleep verwendet.
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliSeconds 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 SCLhi = 1
Const SCLlo = 0
Const SDAhi = 2
Const SDAlo = 0
Const DChi = 4
Const DClo = 0
Const REShi = 8
Const RESlo = 0
Const PowerOn = 48

Dim LastBit As Long

Private LcdPort As Long
Private LcdContrast As Long
Private Charset(0 To 255) As String

'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 des Display-Kontrasts. Der Wert muss zwischen 0 und 31 liegen. Alles andere wird ignoriert.
Property Let Contrast(NewContrast As Long)
If NewContrast <= 127 And NewContrast >= 0 Then
  LcdContrast = NewContrast
  OutLcd 33, True   'H auf 1 setzen
  OutLcd 128 + LcdContrast, True
  OutLcd 32, True   'H auf 0 setzen
Else
  LcdContrast = 60
End If
End Property

'Ausgabe des Kontrasts:
Property Get Contrast() As Long
Contrast = LcdContrast
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

'Ausgabe an das LC-Display. LcdData beinhaltet die Daten, LcdControl bestimmt, ob die
'Daten an das Display ausgegeben werden sollen oder als Befehl behandelt werden soll.
Private Function OutLcd(ByVal LcdData As Long, ByVal LcdControl As Boolean)
Dim x As Long
Dim CommandBit As Long
Dim BinLcdData As String

If LcdControl = True Then
  CommandBit = DClo
Else
  CommandBit = DChi
End If

BinLcdData = DeztoBin(LcdData)
PortOut32 LcdPort, CommandBit + REShi + PowerOn + LastBit
For x = 1 To 8
  If Mid(BinLcdData, x, 1) = 1 Then  '(LcdData And Round(Exp(X * 0.69314718)))
    PortOut32 LcdPort, CommandBit + SCLlo + SDAhi + REShi + PowerOn
    PortOut32 LcdPort, CommandBit + SCLhi + SDAhi + REShi + PowerOn
    LastBit = SCLhi + SDAhi
  Else
    PortOut32 LcdPort, CommandBit + SCLlo + SDAlo + REShi + PowerOn
    PortOut32 LcdPort, CommandBit + SCLhi + SDAlo + REShi + PowerOn
    LastBit = SCLhi + SDAlo
  End If
Next
End Function

Function Init()
Dim x As Long
LastBit = 0
PortOut32 LcdPort, RESlo + PowerOn 'Das Display resetten
PortOut32 LcdPort, REShi + PowerOn
OutLcd 33, True  'Function set (IC aktiv, horizontale Adressierung, H=1!!)
OutLcd 188, True 'Kontrast 60 (128 + Kontrast)
OutLcd 6, True   'Temperaturkompensierung (Koeffizient 2)
OutLcd 19, True  'Bias (3, entspricht 1:48)
OutLcd 32, True  'Function set (IC aktiv, horizontale Adressierung, H=0)
OutLcd 12, True  'Display control (D=1 E=0: Normaler Modus)
OutLcd 64, True  'Zeile auf 0 setzen
OutLcd 128, True 'Spalte auf 0 setzen
OutLcd 12, True  'Display control (D=1 E=0: Normaler Modus)
For x = 1 To 504 'Displayinhalt löschen
  OutLcd 0, False
Next
End Function

'Die angegebene Picturebox auf das Display übertragen
Function WritePic(ByVal LcdPicture As PictureBox)
Dim x, currPage
Dim StrRev As Boolean
Dim OldScaleMode As ScaleModeConstants
OldScaleMode = LcdPicture.ScaleMode 'Scalemode merken
LcdPicture.ScaleMode = 3 'Scalemode auf Pixel stellen
For x = 0 To 6
  OutLcd 64 + x, True  'Zeile auf 0 setzen
  OutLcd 128, True 'Spalte auf 0 setzen
  WritePicLine LcdPicture, x * 8 'Zeile x an das Display ausgeben
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 Ystart As Long)
Dim Temp As String
Dim Xval, Yval
For Xval = 0 To 83
  Temp = ""
  For Yval = Ystart To (Ystart + 7)
     If GetPixel(LcdPicture.hDC, Xval, Yval) = 0 Then
       Temp = Temp & "1"
     Else
       Temp = Temp & "0"
     End If
  Next Yval
  
  OutLcd BintoDez(StrReverse(Temp)), False
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 InitFont(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
      Charset(Mid(Temp, 1, 3)) = Right(Temp, Len(Temp) - 3)
  Loop
Close FHandle
InitFont = True
Exit Function
Fehler:
InitFont = False
End Function

'Den angegebenen Text der initialisierten Schriftart auf eine PictureBox mit hDc schreiben.
Function WriteText(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
WriteText = True
Exit Function
Fehler:
DstPicture.ScaleMode = OldScaleMode 'Scalemode zurücksetzen
WriteText = False
End Function

'Berechnen der Textlänge in Pixeln anhand der geladenen Schriftart und dem gewünschten Text
Function TextLength(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

TextLength = TxtLen
End Function

Function ClearDisplay()
Dim x As Long
OutLcd 64, True 'Y-Adresse auf 0 setzen
OutLcd 128, True 'X-Adresse auf 0 setzen
For x = 0 To 504 'lieber bisschen mehr...
  OutLcd 0, False
Next
OutLcd 64, True 'Y-Adresse auf 0 setzen
OutLcd 128, True 'X-Adresse auf 0 setzen
End Function

Function ShowNoise()
Dim x As Long
Randomize
OutLcd 64, True 'Y-Adresse auf 0 setzen
OutLcd 128, True 'X-Adresse auf 0 setzen
For x = 0 To 504
  OutLcd Rnd * 255, False
Next
End Function

'Testet die Übertragungsgeschwindigkeit eines kompletten Displayinhaltes an das Display
'Die Ausgabe erfolgt in ms
Function TestLcdSpeed() As Currency
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"
QueryPerformanceCounter PerfCntB 'den Endwert für den Counter in PerfCntB schreiben
TestLcdSpeed = CDbl((PerfCntB - PerfCntA) / PerfFrequ) * 1000
End Function