frmmain.frm

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

    ckey = RegSetValueEx(HK, "字节排列", 0, REG_DWORD, KeyValue(7), 4) '
    ckey = RegSetValueEx(HK, "取字方式", 0, REG_DWORD, KeyValue(8), 4)
    ckey = RegSetValueEx(HK, "输出格式", 0, REG_DWORD, KeyValue(9), 4)
    ckey = RegSetValueEx(HK, "字符集", 0, REG_DWORD, &H86&, 4)
    ckey = RegSetValueEx(HK, "允许重码", 0, REG_DWORD, &H0&, 4)
    ckey = RegSetValueEx(HK, "西文字符", 0, REG_DWORD, 0&, 4)
    ckey = RegSetValueEx(HK, "生成字库变量", 0, REG_DWORD, 1&, 4)
    ckey = RegSetValueEx(HK, "生成字符码表", 0, REG_DWORD, 0&, 4)
    ckey = RegSetValueEx(HK, "混合输出", 0, REG_DWORD, 0&, 4)
    ckey = RegSetValueEx(HK, "变量起始值", 0, REG_DWORD, 0&, 4)
    ckey = RegSetValueEx(HK, "变量增量", 0, REG_DWORD, 1&, 4)
  End If
  RegCloseKey (HK)
End Sub

Private Function GetSettingsKey() As Long
  Dim ret As Long
  ret = RegCreateKey(HKEY_CURRENT_USER, "Software", HK)
  If ret = 0 Then
    ret = RegCreateKey(HK, "ZSR Applications", HK)
    If ret = 0 Then
      ret = RegCreateKey(HK, "HZDotReader", HK)
      If ret = 0 Then
        ret = RegCreateKey(HK, "Settings", HK)
      End If
    End If
  End If
  GetSettingsKey = ret
End Function

Private Function GetExistStr(ByVal DstStrFile As String)
  Dim fno2 As Integer, CurLoc As Long, Tmb() As Byte
  On Error GoTo ReadOldErr
  fno2 = FreeFile()
  Open DstStrFile For Binary Access Read As fno2
  CurLoc = LOF(fno2)
  ReDim Tmb(0 To CurLoc - 1)
  Get #fno2, , Tmb
  Close #fno2
  GetExistStr = StrConv(Tmb, vbUnicode)
  Exit Function
ReadOldErr:
  Close #fno2
  GetExistStr = ""
End Function

Private Sub MakeOut()
  Dim i As Long, srcPath As String, dstPath As String, ffnd As Integer
  Call SaveRecent
  i = InStrRev(txtChineseFile.Text, "\"):  dstPath = Left(txtChineseFile.Text, i - 1)
  Call WritePrivateProfileString("PATH", "保存文件路径", dstPath, IniFile)
  i = InStrRev(LstSrcFile.List(0), "\"):    srcPath = Left(LstSrcFile.List(0), i - 1)
  Call WritePrivateProfileString("PATH", "源文件路径", srcPath, IniFile)
  Call PrepairMakeChLib

  i = AutoMaker()
  Erase sFntsize:   Erase FntName:    Erase FntWidth:    Erase FntHeight
  Erase txtFile:    Erase ftxtno:     Erase FntCFile:    Erase EntireStr
  OutDstFile = txtChineseFile.Text
  PageInd = 0
  ReDim Preserve PageStart(0 To PageInd):   PageStart(PageInd) = 1
  Call DispFromDestFile(OutDstFile)
End Sub

Private Sub PrepairMakeChLib()
  MyAppPath = App.Path:  If Right(MyAppPath, 1) <> "\" Then MyAppPath = MyAppPath + "\"
  FntKinds = 0
  ReDim sFntsize(0 To FntKinds)
  ReDim FntName(0 To FntKinds)
  ReDim FntWidth(0 To FntKinds)
  ReDim FntHeight(0 To FntKinds)
  ReDim txtFile(0 To FntKinds)
  ReDim ftxtno(0 To FntKinds)
  ReDim FntCFile(0 To FntKinds)
  ReDim EntireStr(0 To FntKinds)
  If Dir(txtChineseFile.Text) <> "" Then Kill (txtChineseFile.Text)
End Sub

Private Function AutoMaker() As Long
  Dim i As Long, ffnd As Integer, sStr As String, estr As String
  For i = 0 To LstSrcFile.ListCount - 1
    If Not FetchOneFile(LstSrcFile.List(i)) Then Exit Function
  Next i
  For i = 0 To FntKinds - 1
    Close #ftxtno(i)
  Next i
  estr = "":  AutoMaker = 0
  For i = 0 To FntKinds - 1
    Call SetHZDotReader(i)
    If Dir(FntCFile(i)) <> "" Then Kill (FntCFile(i))
    If RunHZDotReader(txtFile(i), FntCFile(i)) Then
      If FntLibConv(i, txtChineseFile.Text) Then AutoMaker = AutoMaker + ChnCnt: estr = estr + "      " + CStr(ChnCnt) + "个" + sFntsize(i) + "点阵汉字的字模！" + vbCrLf
    End If
    If chkReserveTempFile(1).Value = 0 Then If Dir(txtFile(i)) <> "" Then Kill (txtFile(i))
    If chkReserveTempFile(0).Value = 0 Then If Dir(FntCFile(i)) <> "" Then Kill (FntCFile(i))
  Next i
  MsgBox "完成！共生成:" + vbCrLf + estr, vbInformation
End Function

Private Function GetFntSize(ByVal Fn As Integer, FntSize() As Long) As Long
  Dim cur As Long, Ch(0 To 1) As Byte, CommentsBegin As Boolean, CommentsEnd As Boolean
  Dim Ss As String, i As Long, j As Long
  cur = Loc(Fn): CommentsEnd = False: Ch(1) = 0: CommentsBegin = False
  While (Not CommentsEnd) And cur < LOF(Fn)
    Ch(0) = Ch(1): Get #Fn, , Ch(1):  cur = Loc(Fn)
    CommentsEnd = (Ch(0) = Asc(vbCr) And Ch(1) = Asc(vbLf))
    If Not CommentsEnd Then
      If Not CommentsBegin Then
        CommentsBegin = (Ch(0) = Asc("/") And Ch(1) = Asc("/"))
      ElseIf Ch(1) <> Asc(" ") Then
        Ss = Ss + Chr(Ch(1))
      End If
    End If
  Wend
  Ss = UCase(Ss):  i = InStr(Ss, "X"):  If i = 0 Then i = InStr(Ss, "×")
  If i > 0 Then
    j = i - 2: If j < 1 Then j = 1
    FntSize(0) = Val(Mid(Ss, j, 2)):   FntSize(1) = Val(Mid(Ss, i + 1, 2))
  Else
    FntSize(0) = DefaultFntWidth: FntSize(1) = DefaultFntHeight
  End If
  GetFntSize = SearchFontKindsInd(FntName(0), FntSize(0), FntSize(1))
End Function

Private Function SearchFontKindsInd(ByVal CurFntName As String, ByVal CurFntW As Long, ByVal CurFntH As Long) As Long
  Dim i As Long
  For i = 0 To FntKinds - 1
    If CurFntName = FntName(i) And CurFntW = FntWidth(i) And CurFntH = FntHeight(i) Then Exit For
  Next i
  If i > (FntKinds - 1) Then
    ReDim Preserve FntName(0 To FntKinds)
    ReDim Preserve FntWidth(0 To FntKinds)
    ReDim Preserve FntHeight(0 To FntKinds)
    ReDim Preserve sFntsize(0 To FntKinds)
    ReDim Preserve txtFile(0 To FntKinds)
    ReDim Preserve ftxtno(0 To FntKinds)
    ReDim Preserve FntCFile(0 To FntKinds)
    ReDim Preserve EntireStr(0 To FntKinds)
    FntName(FntKinds) = CurFntName
    FntWidth(FntKinds) = CurFntW: FntHeight(FntKinds) = CurFntH
    sFntsize(FntKinds) = FntName(FntKinds) + CStr(FntWidth(FntKinds)) + "X" + CStr(FntHeight(FntKinds))
    txtFile(FntKinds) = MyAppPath + "$$$" + sFntsize(FntKinds) + ".TXT"
    FntCFile(FntKinds) = MyAppPath + "$$$" + sFntsize(FntKinds) + ".C"
    EntireStr(FntKinds) = ""
    ftxtno(FntKinds) = FreeFile()
    Open txtFile(FntKinds) For Append As ftxtno(FntKinds)
    i = FntKinds:    FntKinds = FntKinds + 1
  End If
  SearchFontKindsInd = i
End Function

Private Function StepOverComments(ByVal Fn As Integer, ByVal Block As Boolean) As Long
  Dim cur As Long, Ch(0 To 1) As Byte, CommentsEnd As Boolean
  cur = Loc(Fn): CommentsEnd = False
  While (Not CommentsEnd) And cur < LOF(Fn)
    Ch(0) = Ch(1): Get #Fn, , Ch(1):  cur = Loc(Fn)
    CommentsEnd = (Block And Ch(0) = Asc("*") And Ch(1) = Asc("/"))
    If Not CommentsEnd Then CommentsEnd = ((Not Block) And Ch(0) = Asc(vbCr) And Ch(1) = Asc(vbLf))
  Wend
  StepOverComments = cur
End Function

Private Function OpenFile(ByVal Op As Long, ByVal Path As String, ByVal Filter As String) As String
  With CommonDialog1
    .InitDir = Path
    .DialogTitle = IIf(Op = FILE_OPEN, "打开", "保存") + "文件"
    .Filter = Filter + "|所有文件(*.*)|*.*"
    .FilterIndex = 0
    .FileName = ""
    .Flags = cdlOFNHideReadOnly + IIf(Op = FILE_OPEN, cdlOFNAllowMultiselect, 0)
    On Error GoTo OpenCalcCancel
    If Op = FILE_OPEN Then
      .DefaultExt = "":     .ShowOpen
    Else
      .DefaultExt = ".C":    .ShowSave
    End If
    OpenFile = .FileName
  End With
  Exit Function
OpenCalcCancel:
  If Err.Number <> cdlCancel Then MsgBox Err.Description, vbCritical + vbSystemModal, CommonDialog1.DialogTitle
  OpenFile = ""
End Function

Private Function RunHZDotReader(ByVal txtFile As String, ByVal OutFile As String) As Boolean
  Dim pID&, pHwnd&, KeyStr As String
  On Error GoTo RunCfgErr
  ChDir (App.Path)
  pID = Shell(App.Path + "\HZDotReader.Exe", vbNormalFocus)
  pHwnd = OpenProcess(SYNCHRONIZE, 0, pID)
  DoEvents: DoEvents
  If pHwnd <> 0 Then
    SendKeys "%EF" + txtFile + "%O%EO%FS" + OutFile + "%SY%FX", True
    DoEvents
    pID = WaitForSingleObject(pHwnd, INFINITE) '1000) '
    CloseHandle pHwnd
  End If
  RunHZDotReader = True
  Exit Function
RunCfgErr:
  MsgBox Err.Description, vbCritical + vbSystemModal, "运行HZDotReader"
  RunHZDotReader = False
End Function

Private Function FntLibConv(ByVal ind As Long, ByVal OFile As String) As Boolean
  Dim ffn As Integer, i As Long, str As String, str2 As String, Ostr As String
  Dim ffn2 As Integer
  On Error GoTo ConvErr
  ffn = FreeFile()
  Open FntCFile(ind) For Input As ffn
  str = "": Ostr = "": ChnCnt = 0
  While Not EOF(ffn) And str <> "unsigned char"
    Line Input #ffn, str
    str = Left(str, 13)
  Wend
  While Not EOF(ffn)
    Line Input #ffn, str
    Select Case Left(str, 2)
      Case "0x":      Ostr = Ostr + str
      Case "/*":      Ostr = Ostr + Chr(34) + Mid(str, 3, 1) + Chr(34) + ",": ChnCnt = ChnCnt + 1
      Case Else:      Ostr = Ostr + vbCrLf
    End Select
  Wend
  Close #ffn
  ffn2 = FreeFile()
  Open OFile For Append As ffn2
  If LOF(ffn2) = 0 Then Print #ffn2, txtHeader.Text
  Print #ffn2, "//_____________________" + sFntsize(ind) + "点阵汉字库__________________________________________________________________________________________________________________________"
  Print #ffn2, "const unsigned int code Font" + sFntsize(ind) + "CNT=" + CStr(ChnCnt) + ";"
  Print #ffn2, "struct typFNT_GB" + sFntsize(ind) + " code GB" + sFntsize(ind) + "[] = {"
  Print #ffn2, Ostr + "};"
  Print #ffn2, "//___________________________________________________________________________________________________________________________________________________________________________"
  Close #ffn2
  FntLibConv = True
  Exit Function
ConvErr:
  MsgBox Err.Description, vbExclamation, sFntsize(ind) + "点阵字库转换"
  FntLibConv = False
End Function

Private Sub chkUseDotFnt_Click()
  Dim spec As Boolean, i As Long
  spec = Not (chkUseDotFnt.Value = 1)
  fraSpecial.Enabled = spec
  For i = 0 To 3
    chkFntSpecial(i).Enabled = spec
  Next i
End Sub

Private Sub ComboFntName_Click()
  Dim i As Long, ind As Integer
  ind = ComboFntName.ListIndex
  ComboFntSize(ind).Visible = True
  ComboFntSize(ind).Tag = "NO"
  Call ComboFntSize_Click(ind)
  ComboFntSize(ind).Tag = ""
  For i = 0 To ComboFntName.ListCount - 1
    If i <> ind Then ComboFntSize(i).Visible = False
  Next i
  If Me.Visible Then Call FontDemo(App.ProductName)
End Sub

Private Sub ComboFntSize_Change(Index As Integer)
  Call ComboFntSize_Click(Index)
End Sub

Private Sub ComboFntSize_Click(Index As Integer)
  Dim DotFile As String, i As Long, j As Long
  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
    chkUseDotFnt.Value = 0: chkUseDotFnt.Enabled = False
  Else: chkUseDotFnt.Value = 1:   chkUseDotFnt.Enabled = True
  End If
  If Me.Visible And ComboFntSize(Index).Tag = "" Then Call FontDemo(App.ProductName)
End Sub

Private Sub Form_Load()
  Dim Capt As String
  Capt = App.ProductName + " V" + CStr(App.Major) + "." + CStr(App.Minor) + "." + CStr(App.Revision)
  Me.Caption = Capt
  IniFile = App.ProductName + ".INI"
  Pow2 = Array(1, 2, 4, 8, 16, 32, 64, 128)
  Call ScanAvailableFont
  If ComboFntName.ListCount Then ComboFntName.ListIndex = 0
  If chkUseDotFnt.Enabled Then chkUseDotFnt.Value = 1
End Sub

Private Sub ScanAvailableFont()
  Dim i As Long, FntName As String
  ComboFntName.Clear:   ComboFntSize(0).Clear
  FntName = Trim(Dir(App.Path + "\*体*.dot", vbNormal))
  While FntName <> ""
    FntName = Left(FntName, InStrRev(FntName, ".") - 1)
    i = AddFntNameInCombo0(FntName)
    FntName = Trim(Dir())
  Wend
  For i = 0 To ComboFntName.ListCount - 1
    ComboFntName.ListIndex = i
    ComboFntSize(i).ListIndex = 0
  Next i
End Sub

Private Function AddFntNameInCombo0(ByVal FntName As String) As Long
  Dim i As Long, j As Long, FntSiz As Long, m As Long, Found As Boolean
  FntSiz = Val(Right(FntName, 2)): FntName = Left(FntName, Len(FntName) - 2)
  With ComboFntName
    For i = 0 To .ListCount - 1
      If FntName = .List(i) Then Exit For
    Next i
    If i >= .ListCount Then
      .AddItem FntName:      If i > 0 Then Load ComboFntSize(i)
    End If
    AddFntNameInCombo0 = i
  End With
  With ComboFntSize(i)
    Found = False