modpubsub.bas

12864 lcd 的字模提取软件

Attribute VB_Name = "modPubSub"
Option Explicit

Public Const LEFT_MARGIN As Integer = 10
Public Const TOP_MARGIN As Integer = 10
Public Const LCD_DOT_SIDE_LENGTH  As Integer = 3
Public Const LCD_DOT_DOT_SPACE  As Integer = 2
Public Const BASIC_CHARS   As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"
Public Const SPECIAL_CHARS As String = ".-=/>?~""%"


Public Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
Public Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Public Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Public Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long

Public sChineseCharacters As String
Public sAllCharacters As String

Public bCapture As Boolean
Public Data(0 To 7, 0 To 127) As Byte
Public SaveData(0 To 7, 0 To 127) As Byte
Public MouseX As Integer
Public MouseY As Integer

Public Type udtFontInfo
  Name As String
  Size As Byte
End Type

Public Type udtCharInfo
  Top As Byte
  Bottom As Byte
  Left As Byte
  Right As Byte
  Width As Byte
  Height As Byte
End Type

Public Enum emFontKind
  emPrimarySmall = 1
  emSecondarySmall = 2
  emPrimaryBig = 3
  emSecondaryBig = 4
End Enum

Public mPrimarySmallFont As udtFontInfo
Public mSecondarySmallFont As udtFontInfo
Public mPrimaryBigFont As udtFontInfo
Public mSecondaryBigFont As udtFontInfo

Public Function Add0Hex(ByVal n As Byte) As String
  Add0Hex = IIf(n < 16, "0", "") & Hex(n)
End Function

Public Sub BackupData()
  Dim i As Byte
  Dim j As Byte
  
  For i = 0 To 7
    For j = 0 To 127
      SaveData(i, j) = Data(i, j)
    Next j
  Next i
End Sub

Public Sub RestoreData()
  Dim i As Byte
  Dim j As Byte
  Dim k  As Byte
  
  For i = 0 To 7
    For j = 0 To 127
      Data(i, j) = SaveData(i, j)
      For k = 0 To 7
        Call ShowPt(j, i * 8 + k, (Data(i, j) And (2 ^ k)) <> 0)
      Next k
    Next j
  Next i
End Sub

Public Sub GenerateImage(ByVal x1 As Byte, ByVal y1 As Byte)
  Dim MyDc As Long
  Dim X As Byte
  Dim Y As Byte
  Dim x0 As Integer
  Dim y0 As Integer
  Dim bSet As Boolean
  Dim MyChar As udtCharInfo
  
  Call GetCharSize(MyChar, False)
  
  MyDc = GetDC(frmMain.txtChar.hWnd)
  Call BackupData
  For X = MyChar.Left To MyChar.Right
    For Y = MyChar.Top To MyChar.Bottom
      bSet = IsPixelChar(GetPixel(MyDc, X, Y))
      x0 = X - MyChar.Left + x1
      y0 = Y - MyChar.Top + y1
      Call ShowPt(x0, y0, bSet)
      Call SetData(y0, x0, bSet)
    Next Y
  Next X
  CloseHandle MyDc
End Sub

Public Sub AdjustCharPos(ByVal Ch As String, ByRef CharTop As Byte, ByRef CharBottom As Byte, ByVal bBigTrueSmallFalse As Boolean)
  If bBigTrueSmallFalse Then '16×16 大字体
  
    Select Case Ch
      Case Else
        
    End Select
    
  Else '8×8 小字体
  
    Select Case Ch
      Case Else
        
    End Select
    
  End If
End Sub

Public Sub SetTextOrLabelFontByCDlg(ByRef ctl As Control)
  Debug.Assert TypeName(ctl) = "Label" Or TypeName(ctl) = "TextBox"
  With ctl
    .FontBold = frmMain.cdlg.FontBold
    .FontItalic = frmMain.cdlg.FontItalic
    .FontName = frmMain.cdlg.FontName
    .FontSize = frmMain.cdlg.FontSize
    .FontStrikethru = frmMain.cdlg.FontStrikethru
    .FontUnderline = frmMain.cdlg.FontUnderline
    .ForeColor = frmMain.cdlg.Color
    
    If TypeName(ctl) = "Label" Then
      .Caption = frmMain.cdlg.FontName & " " & CStr(frmMain.cdlg.FontSize)
    End If
  End With
End Sub

Public Sub SetFontInfo(ByRef fi As udtFontInfo, ByVal Name As String, ByVal Size As Byte)
  fi.Name = Name
  fi.Size = Size
End Sub

Public Sub ShowCharInfo()
  Dim MyDc As Long
  Dim X As Byte
  Dim Y As Byte
  Dim t As Byte
  Dim s As String
  Dim Page As Byte
  Dim sCharData As String
  Dim YInit As Byte
  Dim MyChar As udtCharInfo
  
  Call GetCharSize(MyChar, False)
  
  If MyChar.Bottom - MyChar.Top > 7 Then
    Call AdjustCharPos(frmMain.txtChar.Text, MyChar.Top, MyChar.Bottom, True)
  Else
    Call AdjustCharPos(frmMain.txtChar.Text, MyChar.Top, MyChar.Bottom, False)
  End If
    
  s = ""
  s = s & "字符" & IIf(Len(frmMain.txtChar.Text) = 1, "", "串") & "“" & frmMain.txtChar.Text & "”的信息：" & vbCrLf & vbCrLf
  s = s & "宽：" & CStr(MyChar.Width) & vbCrLf
  s = s & "高：" & CStr(MyChar.Height) & vbCrLf & vbCrLf
  s = s & "点阵数据：" & vbCrLf
  
  sCharData = ""
  MyDc = GetDC(frmMain.txtChar.hWnd)
  
  For Page = 1 To (MyChar.Height) \ 8 + 1
    For X = MyChar.Left To MyChar.Right
      t = 0
      YInit = MyChar.Top + (Page - 1) * 8
      For Y = YInit To YInit + 7
        If IsPixelChar(GetPixel(MyDc, X, Y)) Then
          t = t + 2 ^ (Y - YInit)
        End If
      Next Y
      sCharData = sCharData & "0x" & Add0Hex(t) & ","
    Next X
    sCharData = sCharData & vbCrLf
  Next Page
  
  
  CloseHandle MyDc
  
  frmMain.txtCode.Text = s & sCharData
End Sub

Public Sub GetCharSize(ByRef MyChar As udtCharInfo, Optional ByVal bFastMode As Boolean = True)
  Dim MyDc As Long
  Dim X As Integer
  Dim Y As Integer
  Dim FinalValue As Integer
  
  FinalValue = IIf(bFastMode, 20, 200)
  MyDc = GetDC(frmMain.txtChar.hWnd)
  
  For X = 0 To FinalValue
    For Y = 0 To FinalValue
      If IsPixelChar(GetPixel(MyDc, X, Y)) Then
        MyChar.Left = X
        GoTo GetRight:
      End If
    Next Y
  Next X
  
GetRight:
  For X = FinalValue To 0 Step -1
    For Y = 0 To FinalValue
      If IsPixelChar(GetPixel(MyDc, X, Y)) Then
        MyChar.Right = X
        GoTo GetTop:
      End If
    Next Y
  Next X

GetTop:
  For Y = 0 To FinalValue
    For X = 0 To FinalValue
      If IsPixelChar(GetPixel(MyDc, X, Y)) Then
        MyChar.Top = Y
        GoTo GetBottom:
      End If
    Next X
  Next Y

GetBottom:
  For Y = FinalValue To 0 Step -1
    For X = 0 To FinalValue
      If IsPixelChar(GetPixel(MyDc, X, Y)) Then
        MyChar.Bottom = Y
        GoTo GetWidthAndHeight:
      End If
    Next X
  Next Y

GetWidthAndHeight:
  MyChar.Width = MyChar.Right - MyChar.Left + 1
  MyChar.Height = MyChar.Bottom - MyChar.Top + 1

  CloseHandle MyDc
End Sub
Public Function IsPixelChar(ByVal lColor As Long) As Boolean
  IsPixelChar = (lColor <> vbWhite And lColor <> -1)
End Function

Public Sub SetData(ByVal X As Integer, ByVal Y As Integer, ByVal bFlag As Boolean)
  Dim XPage As Byte
  Dim Pos As Byte

  If X >= 0 And X <= 63 And Y >= 0 And Y <= 127 Then
    XPage = Int(X / 8)
    Pos = X Mod 8
    If bFlag Then
      Data(XPage, Y) = Data(XPage, Y) Or (1 * 2 ^ Pos)
    Else
      Data(XPage, Y) = Data(XPage, Y) And (Not (1 * 2 ^ Pos))
    End If
  End If
End Sub

Public Sub ShowPt(ByVal X As Integer, ByVal Y As Integer, ByVal bFlag As Boolean)
  If X >= 0 And X <= 127 And Y >= 0 And Y <= 63 Then
    frmMain.ForeColor = IIf(bFlag, vbBlack, &HC000&)
    frmMain.FillColor = IIf(bFlag, vbBlack, &HC000&)
    frmMain.Line (LEFT_MARGIN + X * (LCD_DOT_SIDE_LENGTH + LCD_DOT_DOT_SPACE), TOP_MARGIN + Y * (LCD_DOT_SIDE_LENGTH + LCD_DOT_DOT_SPACE))-Step(LCD_DOT_SIDE_LENGTH, LCD_DOT_SIDE_LENGTH), , B
  End If
End Sub

Public Function GetFontHeightInvalidString(ByVal MaxHeight As Byte) As String
  Dim i As Byte
  Dim s As String
  Dim MyChar As udtCharInfo
  
  Debug.Assert MaxHeight = 8 Or MaxHeight = 16
  
  s = ""
  For i = 1 To Len(sAllCharacters)
    frmMain.txtChar.Text = Mid(sAllCharacters, i, 1)
    DoEvents
    
    Call GetCharSize(MyChar)
    If MyChar.Height > MaxHeight Then
      s = s & Chr(i)
    End If
  Next i
  
  GetFontHeightInvalidString = s
End Function

Public Sub HightlightCmdBtn(ByRef cmd As CommandButton)
  With frmMain
    .cmdPrimaryBigFont.BackColor = vbButtonFace
    .cmdSecondaryBigFont.BackColor = vbButtonFace
    .cmdPrimarySmallFont.BackColor = vbButtonFace
    .cmdSecondarySmallFont.BackColor = vbButtonFace
    cmd.BackColor = &HEAFFEA
  End With
End Sub

Public Sub SetTextboxFont(ByVal emFont As emFontKind)
  With frmMain.txtChar
    Select Case emFont
      Case emPrimarySmall
        .FontName = mPrimarySmallFont.Name
        .FontSize = mPrimarySmallFont.Size
      Case emSecondarySmall
        .FontName = mSecondarySmallFont.Name
        .FontSize = mSecondarySmallFont.Size
      Case emPrimaryBig
        .FontName = mPrimaryBigFont.Name
        .FontSize = mPrimaryBigFont.Size
      Case emSecondaryBig
        .FontName = mSecondaryBigFont.Name
        .FontSize = mSecondaryBigFont.Size
      Case Else
        MsgBox "No define font!", vbCritical, "Sub SetTextboxFont"
    End Select
  End With
End Sub

Public Function RTrim1(ByVal s As String) As String
  RTrim1 = Left(s, Len(s) - 1)
End Function