frmmain.frm

1、从Keil C源代码中自动提取中文字符

    For j = 0 To .ListCount - 1
      m = Val(Left(.List(j), 2))
      If FntSiz = m Then Found = True: Exit For
      If FntSiz < m Then Exit For
    Next j
    If Not Found Then .AddItem CStr(FntSiz) + "X" + CStr(FntSiz), j
  End With
End Function

Private Sub Form_Resize()
  PicLCD.ScaleMode = vbPixels
'  ZoomX = 2: ZoomY = 2
'  ZoomX = Screen.TwipsPerPixelX * 2: ZoomY = Screen.TwipsPerPixelY * 2
End Sub

Private Sub lblCmd_Click(Index As Integer)
  Select Case Index
    Case 0:   Call AddSrcFile
    Case 1:   Call LstSrcFile_DblClick
    Case 2:   Call ReadRecent
    Case 3:   Call AddOutFile
    Case 4:   Call MakeOut
    Case 5:   Unload Me
    Case 6:   frmAbout.Show vbModal
    Case 7:   If PageInd > 0 Then PageInd = PageInd - 1: Call DispFromDestFile(OutDstFile)
    Case 8:   PageInd = PageInd + 1:
              If Not DispFromDestFile(OutDstFile) Then
                PageInd = PageInd - 1:  Call DispFromDestFile(OutDstFile)
              End If
  End Select
  If Index < 5 Then lblCmd(4).Enabled = (LstSrcFile.ListCount > 0 And txtChineseFile.Text <> "")
End Sub

Private Sub AddSrcFile()
  Dim i As Long, Src As String, SubStr As Variant, fPath As String * 255
  Call GetPrivateProfileString("PATH", "源文件路径", App.Path, fPath, 255, IniFile)
  Src = Left(fPath, InStr(fPath, Chr(0)) - 1)
  Src = OpenFile(FILE_OPEN, Src, "C源文件(*.C)|*.C|文本文件(*.TXT)|*.TXT")
'  LstSrcFile.Clear
  If InStr(Src, " ") Then
    SubStr = Split(Src, " ")
    For i = 1 To UBound(SubStr)
      Call AddOneSrcfile(SubStr(0) + SubStr(i))
    Next i
  ElseIf Src <> "" Then Call AddOneSrcfile(Src)
  End If
End Sub

Private Sub AddOneSrcfile(ByVal SrcFile As String)
  Dim i As Long
  With LstSrcFile
    For i = 0 To .ListCount - 1
      If SrcFile = .List(i) Then Exit Sub
    Next i
    .AddItem SrcFile
  End With
End Sub

Private Sub AddOutFile()
  Dim Src As String, fPath As String * 255
  Call GetPrivateProfileString("PATH", "保存文件路径", App.Path, fPath, 255, IniFile)
  Src = Left(fPath, InStr(fPath, Chr(0)) - 1)
  txtChineseFile.Text = OpenFile(FILE_SAVE, Src, "C字库文件(*.C)|*.C")
End Sub

Private Sub lblCmd_MouseDown(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
  ShapeCmd(Index).BackColor = &HFF0000
End Sub

Private Sub lblCmd_MouseUp(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
  ShapeCmd(Index).BackColor = &HFF8080
End Sub

Private Sub LstSrcFile_Click()
  lblCmd(1).Enabled = (LstSrcFile.ListIndex >= 0)
'  Call PrepairMakeChLib
'  Call FetchOneFile(LstSrcFile.List(LstSrcFile.ListIndex))
End Sub

Private Sub LstSrcFile_DblClick()
  LstSrcFile.RemoveItem LstSrcFile.ListIndex
  lblCmd(1).Enabled = (LstSrcFile.ListCount > 0) And (LstSrcFile.ListIndex >= 0)
End Sub

Private Sub txtChineseFile_Change()
  lblCmd(4).Enabled = (LstSrcFile.ListCount > 0 And txtChineseFile.Text <> "")
End Sub

Private Sub lblCmd_MouseMove(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
  ShapeCmd(Index).BackColor = &HFF8080
End Sub

Private Sub FraFntLib_MouseMove(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
  Call ClearCmd
End Sub

Private Sub FraInputFile_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
  Call ClearCmd
End Sub

Private Sub LstSrcFile_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
  Call ClearCmd
End Sub

Private Sub txtChineseFile_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
  Call ClearCmd
End Sub

Private Sub txtHeader_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
  Call ClearCmd
End Sub

Private Sub ClearCmd()
  Dim i As Long
  For i = 0 To 8
    ShapeCmd(i).BackColor = FraInputFile.BackColor
  Next i
End Sub

Private Function FetchOneFile(ByVal SrcCFile As String) As Boolean
  Dim fno As Integer, CurLoc As Long, tmpFntSize(0 To 1) As Long
  Dim XA(0 To 1) As Byte, ChnStr As String, ChnSearched As Boolean
  Dim FntIndex As Long
  On Error GoTo FetchErr
  FntIndex = InStrRev(SrcCFile, ".")
  If FntIndex > 0 Then ChnStr = UCase(Mid(SrcCFile, FntIndex + 1))
  SrcFileType = IIf(ChnStr = "C" Or ChnStr = "C51", SRC_C, SRC_TXT)
  fno = FreeFile():  Open SrcCFile For Binary As fno
  CurLoc = Loc(fno)
  If SrcFileType <> SRC_C Then FntIndex = SearchFontKindsInd(ComboFntName.List(ComboFntName.ListIndex), DefaultFntWidth, DefaultFntHeight)
  While CurLoc < LOF(fno)
    ChnSearched = False
    Do
      XA(0) = XA(1):   Get #fno, , XA(1):   CurLoc = Loc(fno)
      ChnSearched = (XA(0) > 128 And XA(1) > 128)
      If Not ChnSearched And SrcFileType = SRC_C Then
        If XA(0) = Asc("/") And (XA(1) = Asc("*") Or XA(1) = Asc("/")) Then
          CurLoc = StepOverComments(fno, XA(1) = Asc("*")):     XA(1) = 0
        End If
      End If
    Loop While (Not ChnSearched) And CurLoc < LOF(fno)
    If ChnSearched Then
      ChnStr = StrConv(XA, vbUnicode):  XA(1) = 0
      If SrcFileType = SRC_C Then
        FntIndex = GetFntSize(fno, tmpFntSize)
        Seek #fno, CurLoc + 1
      End If
      If InStr(EntireStr(FntIndex), ChnStr) = 0 Then
        EntireStr(FntIndex) = EntireStr(FntIndex) + ChnStr
        Print #ftxtno(FntIndex), ChnStr;
      End If
    End If
  Wend
  Close #fno:   FetchOneFile = True
  Exit Function
FetchErr:
  MsgBox "错误" + CStr(Err.Number) + ": " + Err.Description + vbCrLf + SrcCFile, vbCritical, "提取源文件错误"
End Function

Private Sub FontDemo(ByVal ChStr As String)
  Dim DotFile As String, i As Long, j As Long, DemoStr As String, Ch As String
  On Error GoTo DemoErr
  DemoStr = ""
  For i = 1 To Len(ChStr)
    Ch = Mid(ChStr, i, 1):    If Asc(Ch) < 0 Then DemoStr = DemoStr + Ch
  Next i
  DotFile = App.Path: If Right(DotFile, 1) <> "\" Then DotFile = DotFile + "\"
  i = ComboFntName.ListIndex
  DefaultFntWidth = Val(Left(ComboFntSize(i).Text, 2))
  DefaultFntHeight = Val(Right(ComboFntSize(i).Text, 2))
  DotFile = DotFile + ComboFntName.List(i) + CStr(DefaultFntWidth) + ".dot"
  If DefaultFntWidth <> DefaultFntHeight Or Dir(DotFile) = "" Then PicLCD.Cls: Exit Sub
  Call DrawLCD(DotFile, DemoStr, DefaultFntWidth, DefaultFntHeight)
  lblFontPreview(1).Visible = False:    lblFontPreview(2).Visible = False
  Exit Sub
DemoErr:
  MsgBox "错误" + CStr(Err.Number) + ": " + Err.Description + vbCrLf + DotFile, vbCritical, "字体仿真"
End Sub

Private Function GetChrFormDotFile(ByVal DotFn As Integer, ByVal BytesPerChr As Long, ByVal Ascii As Integer, Buf() As Byte) As Boolean
  Dim Offset As Long, Qu As Long, Wei As Long, tb() As Byte
  ReDim tb(0 To BytesPerChr - 1)
  Ascii = Ascii - &HA1A1
  Qu = Ascii \ 256: Wei = Ascii Mod 256
  Offset = (Qu * 94 + Wei) * BytesPerChr
  Seek #DotFn, Offset + 1:  Get #DotFn, , tb
  Call RtlMoveMemory(Buf(2), tb(0), BytesPerChr)
End Function

Private Sub DrawLCD(ByVal DotFile As String, ByVal ChStr As String, ByVal ChWid As Long, ByVal ChHeight As Long)
  Dim i As Long, x As Long, y As Long, b As Long, DoBuf() As Byte
  Dim DotFn As Integer, Offset As Long, Ascii As Integer, BytesPerChr As Long
  BytesPerChr = ((ChWid + 7) \ 8) * ChHeight
  ReDim DoBuf(0 To BytesPerChr + 2 - 1)
  DoBuf(0) = ChWid: DoBuf(1) = ChHeight
  DotFn = FreeFile():  Open DotFile For Binary As DotFn
  PicLCD.Visible = False:  PicLCD.Cls
  For i = 1 To Len(ChStr)
    Call GetChrFormDotFile(DotFn, BytesPerChr, Asc(Mid(ChStr, i, 1)), DoBuf)
    Call DrawOneChr(x, y, DoBuf)
    x = x + ChWid: b = b + BytesPerChr
    If ((x + ChWid) * ZoomX) > PicLCD.ScaleWidth Then x = 0: y = y + ChHeight + 1
  Next i
  PicLCD.Visible = True
  Close (DotFn)
End Sub

Private Sub DrawOneChr(ByVal x1 As Long, ByVal y1 As Long, DotBuf() As Byte)
  Dim K As Byte, i As Long, j As Long, p As Long, PClr As Long, ind As Long
  Dim Mn As Long, qn As Long
  x1 = x1 * ZoomX:  qn = x1 + DotBuf(0) * ZoomX - IIf(DotBuf(0) Mod 8, 0, ZoomX)
  y1 = y1 * ZoomY:  Mn = y1 + DotBuf(1) * ZoomY
  K = DotBuf(2):  p = 0:  i = x1: j = y1: ind = 2
  Do
    If (K * (2 ^ p)) And &H80 Then PicLCD.Line (i, j)-Step(ZoomX - 1, ZoomY - 1), FColor, BF
    i = i + ZoomX:    p = p + 1
    If p = 8 Then p = 0: ind = ind + 1: If ind <= UBound(DotBuf) Then K = DotBuf(ind)
    If i >= qn Then
      i = x1: p = 0: j = j + ZoomY: ind = ind + 1: If ind <= UBound(DotBuf) Then K = DotBuf(ind)
    End If
  Loop While j < Mn
End Sub

Private Function DispFromDestFile(ByVal DstFile As String) As Boolean
  Dim DstFn As Integer, x As Long, x1 As Long, y As Long, y1 As Long, ym As Long, DstBuf() As Byte, DispChrOK As Boolean
  Dim PageSize As Long, StartFntW As Long, StartFntH As Long
  On Error GoTo DispFromDestFileErr
  Dim t1 As Long
  t1 = GetTickCount()
  ReDim Preserve DstBuf(0 To 2)
  DstFn = FreeFile():  Open DstFile For Input As DstFn
  x = 0: y = 0:  PageSize = 0
  CurChrInd = PageStart(PageInd): PicLCD.Visible = False: PicLCD.Cls
  DispChrOK = GetOneChrFromDstFile(DstFn, CurChrInd, DstBuf)
  If DispChrOK Then
    StartFntW = DstBuf(0): StartFntH = DstBuf(1):  x1 = x + DstBuf(0):  y1 = y + DstBuf(1) + 1
    lblFontPreview(1).Caption = CStr(StartFntW) + "X" + CStr(StartFntH):
    lblFontPreview(1).Visible = True
  End If
  ym = y1 * ZoomY
  While DispChrOK And ym <= PicLCD.ScaleHeight And StartFntW = DstBuf(0) And StartFntH = DstBuf(1)
    Call DrawOneChr(x, y, DstBuf)
    CurChrInd = CurChrInd + 1:  PageSize = PageSize + 1
    x = x1:  x1 = x + DstBuf(0)
    If (x1 * ZoomX) > PicLCD.ScaleWidth Then
      x = 0: x1 = x + DstBuf(0):  y = y1: y1 = y + DstBuf(1) + 1:  ym = y1 * ZoomY
    End If
    DispChrOK = GetOneChrFromDstFile(DstFn, CurChrInd, DstBuf)
  Wend
  PicLCD.Visible = True:  Close (DstFn)
  lblCmd(7).Enabled = (PageInd > 0):  lblCmd(8).Enabled = DispChrOK
  lblFontPreview(2).Caption = CStr(GetTickCount() - t1) + "ms": lblFontPreview(2).Visible = True
  If (PageInd + 1) > UBound(PageStart) Then
    ReDim Preserve PageStart(0 To PageInd + 1):   PageStart(PageInd + 1) = CurChrInd
  End If
  DispFromDestFile = (PageSize > 0)
  Exit Function
DispFromDestFileErr:
  Close (DstFn):  DispFromDestFile = (PageSize > 0)
  MsgBox "错误" + CStr(Err.Number) + ": " + Err.Description + vbCrLf + DstFile, vbExclamation, "显示输出结果"
End Function

Private Function GetOneChrFromDstFile(ByVal DstFn As Integer, ByVal ChrNo As Long, ByRef DstBuf() As Byte) As Boolean
  Dim m As Long, LibInd As Long, str As String
  LibInd = 0:  Seek #DstFn, 1
  While Not EOF(DstFn) And LibInd <> ChrNo
    Line Input #DstFn, str:  str = Trim(str)
    If Len(str) > 10 Then
      If Asc(str) = 34 And Asc(Mid(str, 3, 1)) = 34 Then
        m = SplitDotDataFromStr(str, DstBuf)
        LibInd = LibInd + 1
      ElseIf Left(str, 6) = "struct" Then
        Call SplitFontSizeFromStr(str, DstBuf(0), DstBuf(1))
        ReDim Preserve DstBuf(0 To (2 + ((DstBuf(0) + 7) \ 8) * DstBuf(1)))
      End If
    End If
  Wend
  GetOneChrFromDstFile = (LibInd = ChrNo)
End Function

Private Function SplitDotDataFromStr(ByVal datastr As String, ByRef DotBuf() As Byte) As Long
  Dim i As Long, Sn As Long, Ch0 As Byte, Ch1 As Byte, n As Long, dotstr() As Byte
  dotstr = StrConv(datastr, vbFromUnicode)
  i = 4:  Sn = UBound(dotstr): Ch1 = 0: n = 2
  While i < Sn
    Ch0 = Ch1: Ch1 = dotstr(i): i = i + 1
    If Ch0 = 48 And Ch1 = 120 Then 'Asc("x")
      If n > UBound(DotBuf) Then ReDim Preserve DotBuf(0 To n)
      Ch0 = dotstr(i):  Ch1 = dotstr(i + 1)
      DotBuf(n) = HexToBin(Ch0) * 16 + HexToBin(Ch1)
      n = n + 1:  i = i + 3
    End If
    Ch0 = Ch1
  Wend
  SplitDotDataFromStr = n
End Function

Private Function HexToBin(ByVal sHex As Integer) As Byte
  If sHex >= 48 And sHex <= 57 Then
    HexToBin = sHex - 48
  Else:  HexToBin = 10 + sHex - 65 ' Asc("A")
  End If
End Function

Private Function SplitFontSizeFromStr(ByVal strStruct As String, ByRef ChrW As Byte, ByRef ChrH As Byte) As Boolean
  Dim i As Long, Sn As Long, Ch As String
  i = 7:  Sn = Len(strStruct):  Ch = ""
  While i < Sn And Not IsNumeric(Ch)
    Ch = Mid(strStruct, i, 1)
    i = i + 1
  Wend
  i = i - 1
  If i <> 0 Then ChrW = Val(Mid(strStruct, i, 2)): ChrH = Val(Mid(strStruct, i + 3, 2)): SplitFontSizeFromStr = True
End Function