frm12864.frm

12864 lcd 的字模提取软件

      EndProperty
      Height          =   210
      Left            =   7290
      TabIndex        =   0
      Top             =   90
      Width           =   735
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long

Private Const x0 As Integer = 10
Private Const y0 As Integer = 10
Private Const d  As Integer = 2
Private Const a  As Integer = 3

Private bCapture As Boolean
Private data(0 To 7, 0 To 127) As Byte
Private CharLeft As Byte
Private CharRight As Byte
Private CharTop As Byte
Private CharBottom As Byte
Private MouseX As Integer
Private MouseY As Integer
Private Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long

Private Sub cmdClear_Click()
  Dim i As Byte
  Dim j As Byte
  
  For i = 0 To 7
    For j = 0 To 127
      data(i, j) = 0
    Next j
  Next i
  
  For i = 0 To 63
    For j = 0 To 127
      Call ShowPt(i, j, False)
    Next j
  Next i
End Sub

Private Sub cmdDispCharSize_Click()
  Dim MyDC As Long
  Dim lColor As Long
  Dim X As Integer
  Dim Y As Integer
  Dim bSet As Boolean
  
  
  MyDC = GetDC(txtChar.hwnd)
  
  bSet = False
  For X = 0 To 200
    For Y = 0 To 127
      lColor = GetPixel(MyDC, X, Y)
      bSet = IsPixelChar(lColor)
      If bSet Then
        CharLeft = X
        Exit For
      End If
    Next Y
    If bSet Then
      Exit For
    End If
  Next X
  
  bSet = False
  For X = 63 + CharLeft To 0 Step -1
    For Y = 0 To 127
      lColor = GetPixel(MyDC, X, Y)
      bSet = IsPixelChar(lColor)
      If bSet Then
        CharRight = X
        Exit For
      End If
    Next Y
    If bSet Then
      Exit For
    End If
  Next X
  
  bSet = False
  For Y = 0 To 127
    For X = CharLeft To 63 + CharLeft
      lColor = GetPixel(MyDC, X, Y)
      bSet = IsPixelChar(lColor)
      If bSet Then
        CharTop = Y
        Exit For
      End If
    Next X
    If bSet Then
      Exit For
    End If
  Next Y
  
  bSet = False
  For Y = 127 + CharTop To 0 Step -1
    For X = CharLeft To 63 + CharLeft
      lColor = GetPixel(MyDC, X, Y)
      bSet = IsPixelChar(lColor)
      If bSet Then
        CharBottom = Y
        Exit For
      End If
    Next X
    If bSet Then
      Exit For
    End If
  Next Y
  
  lblCharSize.Caption = "宽:" & CStr(CharRight + 1 - CharLeft) & ",高:" & CStr(CharBottom + 1 - CharTop)
  
  picLeft.Left = txtChar.Left + ScaleX(1 + CharLeft, vbPixels, vbTwips)
  picTop.Top = txtChar.Top + ScaleY(1 + CharTop, vbPixels, vbTwips)
  picRight.Left = txtChar.Left + ScaleX(66 + CharLeft, vbPixels, vbTwips)
  picBottom.Top = txtChar.Top + ScaleY(130 + CharTop, vbPixels, vbTwips)
  
  picLeft.Top = picTop.Top + picTop.Height
  picRight.Top = picLeft.Top
  picTop.Left = picLeft.Left + picLeft.Width
  picBottom.Left = picTop.Left
End Sub

Private Sub cmdGenstaticCode_Click()
  Dim XPage As Byte
  Dim Y As Byte
  Dim s As String
  
  s = "void " & txtFuncName.Text & "()" & vbCrLf _
    & "{" & vbCrLf
  For XPage = 0 To 7
    For Y = 0 To 127
      If data(XPage, Y) <> 0 Then
        s = s & "  Show8Pts(" & CStr(XPage) & "," _
              & CStr(Y) & "," & data(XPage, Y) _
              & ");" & vbCrLf
      End If
    Next Y
  Next XPage
  s = s & "}" & vbCrLf
  txtCode.Text = s
  Clipboard.SetText s
End Sub

Private Sub cmdGenDynamicCode_Click()
  Dim MyDC As Long
  Dim lColor As Long
  Dim X As Integer
  Dim Y As Integer
  Dim x0 As Integer
  Dim y0 As Integer
  Dim bSet As Boolean
  Dim s As String
  
  cmdDispCharSize_Click
  s = "void " & txtFuncName.Text & "(char x0,char y0,bool flag)" & vbCrLf _
  & "{" & vbCrLf
  cmdDispCharSize_Click
  MyDC = GetDC(txtChar.hwnd)
  For X = CharLeft To CharRight
    For Y = CharTop To CharBottom
      lColor = GetPixel(MyDC, X, Y)
      If IsPixelChar(lColor) Then
        x0 = X - CharLeft
        y0 = Y - CharTop
        s = s & "  ShowPt(x0+" & CStr(x0) & ",y0-" & CStr(y0) & ",flag);" & vbCrLf
      End If
    Next Y
  Next X
  CloseHandle MyDC
  
  s = s & "}" & vbCrLf
  txtCode.Text = s
  Clipboard.SetText s
End Sub

Private Sub cmdGenImg_Click()
  Dim MyDC As Long
  Dim lColor As Long
  Dim X As Integer
  Dim Y As Integer
  Dim bSet As Boolean
  
  cmdDispCharSize_Click
  MyDC = GetDC(txtChar.hwnd)
  For X = CharLeft To CharRight
    For Y = CharTop To CharBottom
      lColor = GetPixel(MyDC, X, Y)
      bSet = IsPixelChar(lColor)
      Call ShowPt(X - CharLeft + Val(txtCharX.Text), Y - CharTop + (127 - Val(txtCharY.Text)), bSet)
      Call SetData(X - CharLeft + Val(txtCharX.Text), Y - CharTop + (127 - Val(txtCharY.Text)), bSet)
    Next Y
  Next X
  CloseHandle MyDC
End Sub

Private Sub cmdSelFont_Click()
  '在使用ShowFont 方法之前，必须给 cdlCFBoth，或 cdlCFScreenFonts 置标识属性。
  cdlg.Flags = cdlCFBoth Or cdlCFEffects
  cdlg.FontName = txtChar.FontName
  cdlg.FontSize = txtChar.FontSize
  
  cdlg.ShowFont
  txtChar.FontBold = cdlg.FontBold
  txtChar.FontItalic = cdlg.FontItalic
  txtChar.FontName = cdlg.FontName
  txtChar.FontSize = cdlg.FontSize
  txtChar.FontStrikethru = cdlg.FontStrikethru
  txtChar.FontUnderline = cdlg.FontUnderline
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
  If KeyCode = vbKeyControl Then
  '  cmdGenImg.SetFocus
    txtCharX.Text = CStr(MouseX)
    txtCharY.Text = CStr(MouseY)
    cmdGenImg_Click
  End If
End Sub

Private Sub Form_Load()
  Dim X As Integer
  Dim Y As Integer
  Dim i As Byte
  Dim lx As Single
  Dim ly As Single
  
  For X = 0 To 63
    For Y = 0 To 127
      Call ShowPt(X, Y, False)
    Next Y
  Next X
  
  Me.ForeColor = vbGreen
  ly = y0 + 128 * (a + d)
  For i = 8 To 56 Step 8
    lx = x0 + i * (a + d) - d / 2
    Line (lx, y0)-(lx, ly)
  Next i
  
  lx = x0 + 64 * (a + d) - d / 2
  ly = y0 + 64 * (a + d) - d / 2
  Line (x0, ly)-(lx, ly)
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  bCapture = True
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
  Dim XPage As Byte
  Dim bSet As Boolean
  Dim Pos As Byte
  
  MouseX = Int((X - x0) / (a + d))
  MouseY = 127 - Int((Y - y0) / (a + d))
  lblCord.Caption = "x=" & CStr(MouseX) & ",y=" & CStr(MouseY)
  
  If bCapture Then
    bSet = (Button = 1)
    Call ShowPt(MouseX, 127 - MouseY, bSet)
    Call SetData(MouseX, 127 - MouseY, bSet)
  End If
End Sub

Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
  bCapture = False
End Sub

Private Sub ShowPt(ByVal X As Integer, ByVal Y As Integer, ByVal bFlag As Boolean)
  If X >= 0 And X <= 63 And Y >= 0 And Y <= 127 Then
    Me.ForeColor = IIf(bFlag, vbWhite, vbBlue)
    Me.FillColor = IIf(bFlag, vbWhite, vbBlue)
    Line (x0 + X * (a + d), y0 + Y * (a + d))-Step(a, a), , B
  End If
End Sub

Private 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, 127 - Y) = data(XPage, 127 - Y) Or (1 * 2 ^ Pos)
    Else
      data(XPage, 127 - Y) = data(XPage, 127 - Y) And (Not (1 * 2 ^ Pos))
    End If
  End If
End Sub

Private Sub txtChar_KeyDown(KeyCode As Integer, Shift As Integer)
  If KeyCode = vbKeyA And Shift = 2 Then
    txtChar.SelStart = 0
    txtChar.SelLength = Len(txtChar.Text)
  End If
End Sub

Private Function IsPixelChar(ByVal lColor As Long) As Boolean
  IsPixelChar = (lColor <> vbWhite And lColor <> vbRed And lColor <> -1)
End Function

Private Sub txtCode_KeyDown(KeyCode As Integer, Shift As Integer)
  If KeyCode = vbKeyA And Shift = 2 Then
    txtChar.SelStart = 0
    txtChar.SelLength = Len(txtChar.Text)
  End If
End Sub

Private Sub txtCode_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
  Clipboard.SetText txtCode.SelText
End Sub