📄 surch.frm
字号:
VERSION 5.00
Begin VB.Form Form1
BorderStyle = 1 'Fixed Single
Caption = "中文字符字模查询小程序 V1.0.0"
ClientHeight = 7050
ClientLeft = 45
ClientTop = 450
ClientWidth = 6120
Icon = "surch.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
ScaleHeight = 7050
ScaleWidth = 6120
StartUpPosition = 2 'CenterScreen
Begin VB.Frame Frame1
Height = 6975
Left = 150
TabIndex = 0
Top = 20
Width = 5775
Begin VB.Frame Frame3
Height = 550
Left = 1560
TabIndex = 8
Top = 120
Width = 4095
Begin VB.OptionButton Option1
Caption = "24X24"
Height = 375
Index = 3
Left = 2880
TabIndex = 12
Top = 120
Width = 975
End
Begin VB.OptionButton Option1
Caption = "16X16"
Height = 375
Index = 2
Left = 1920
TabIndex = 11
Top = 120
Width = 975
End
Begin VB.OptionButton Option1
Caption = "14X14"
Height = 375
Index = 1
Left = 960
TabIndex = 10
Top = 120
Width = 975
End
Begin VB.OptionButton Option1
Caption = "12X12"
Height = 375
Index = 0
Left = 120
TabIndex = 9
Top = 120
Width = 975
End
End
Begin VB.Frame Frame2
Height = 615
Left = 0
TabIndex = 4
Top = 6360
Width = 5775
Begin VB.CommandButton Command5
Caption = "退出"
Height = 350
Left = 4080
TabIndex = 14
Top = 180
Width = 900
End
Begin VB.CommandButton Command4
Caption = "关于"
Height = 350
Left = 3120
TabIndex = 13
Top = 180
Width = 900
End
Begin VB.CommandButton Command3
Caption = "全部复制"
BeginProperty Font
Name = "Tahoma"
Size = 9
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 350
Left = 1080
TabIndex = 7
Top = 180
Width = 975
End
Begin VB.CommandButton Command2
Caption = "清除"
BeginProperty Font
Name = "Tahoma"
Size = 9
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 350
Left = 2160
TabIndex = 6
Top = 180
Width = 900
End
Begin VB.CommandButton Command1
Caption = "查询"
BeginProperty Font
Name = "Tahoma"
Size = 9
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 350
Left = 120
TabIndex = 5
Top = 180
Width = 900
End
End
Begin VB.TextBox Text2
BeginProperty Font
Name = "Tahoma"
Size = 9.75
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 5175
Left = 120
Locked = -1 'True
MultiLine = -1 'True
ScrollBars = 2 'Vertical
TabIndex = 3
Top = 1200
Width = 5535
End
Begin VB.TextBox Text1
BeginProperty Font
Name = "Tahoma"
Size = 9.75
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
IMEMode = 1 'ON
Left = 120
OLEDragMode = 1 'Automatic
OLEDropMode = 2 'Automatic
TabIndex = 1
Top = 720
Width = 5535
End
Begin VB.Label Label1
Caption = "请输中文字符："
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Left = 120
TabIndex = 2
Top = 300
Width = 1335
End
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim oindex As Long
Private Sub Command2_Click()
Text1.Text = ""
Text2.Text = ""
Text1.SetFocus
End Sub
Private Sub Command3_Click()
Clipboard.Clear
Text2.SelStart = 0
Text2.SelLength = Len(Text2.Text)
Clipboard.SetText Text2.Text
Text2.SetFocus
End Sub
Private Sub Command4_Click()
Form2.Show (1)
End Sub
Private Sub Command5_Click()
End
End Sub
Private Sub Form_Load()
Dim path As String
path = App.path
'Label1.Caption = StrConv("请选择:", vbtoUnicode)
If Right$(path, 1) <> "\" Then path = path & "\"
If Dir(path & "hzk16") = "" Then
MsgBox "当前目录下没找到16X16点阵字库", vbOKOnly, "警告"
End
End If
If Dir(path & "hzk14") = "" Then
MsgBox "当前目录下没找到14X14点阵字库", vbOKOnly, "警告"
End
End If
If Dir(path & "hzk12") = "" Then
MsgBox "当前目录下没找到12X12点阵字库", vbOKOnly, "警告"
End
End If
If Dir(path & "hzk24") = "" Then
MsgBox "当前目录下没找到24X24点阵字库", vbOKOnly, "警告"
End
End If
oindex = Val(GetSetting(App.EXEName, "save", "set", ""))
Option1(oindex).Value = True
Me.BorderStyle = 0
End Sub
Private Sub Form_Unload(Cancel As Integer)
End
End Sub
Private Sub Label1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Label1.ToolTipText = "作者：姚通" & vbCrLf & " thank you for your use"
End Sub
Private Sub Option1_Click(Index As Integer)
oindex = Index
SaveSetting App.EXEName, "save", "set", Trim(Index)
End Sub
Private Sub Text1_KeyPress(KeyAscii As Integer)
If KeyAscii = 32 Then KeyAscii = 0
If KeyAscii = 13 Then Command1_Click
End Sub
Private Sub Command1_Click()
On Error Resume Next
If Trim(Text1.Text) = "" Then
Text1.Text = ""
Text1.SetFocus
Exit Sub
End If
Dim icnt As Integer
For icnt = 1 To Len(Me.Text1.Text)
Dim tmp_c As Integer
tmp_c = Asc(Mid(Text1.Text, icnt, 1))
If tmp_c >= 0 And tmp_c < 128 Then
MsgBox "不能有非中文字符！"
Exit Sub
End If
Next
Text2.Text = ""
Dim bufferlength As Long
Dim length As Long
Select Case oindex
Case 0:
bufferlength = 24
length = 12
Case 1:
bufferlength = 28
length = 14
Case 2:
bufferlength = 32
length = 16
Case 3:
bufferlength = 72
length = 24
End Select
Dim buffer() As Byte
Dim tbuffer() As Byte
ReDim tbuffer(bufferlength - 1) As Byte
ReDim buffer(LenB(StrConv(Trim$(Text1.Text), vbFromUnicode)))
buffer = StrConv(Trim$(Text1.Text), vbFromUnicode)
Dim i As Integer, j As Integer, k As Integer, h As Integer
Dim qh As Byte
Dim wh As Byte
Dim offset As Long
Dim path As String
path = App.path
If Right$(path, 1) <> "\" Then path = path & "\"
Select Case length
Case 12:
path = path & "hzk12"
Case 14:
path = path & "hzk14"
Case 16:
path = path & "hzk16"
Case 24:
path = path & "hzk24"
End Select
Open path For Binary As #1
Form3.Show
Form3.ProgressBar1.Min = 1
Form3.ProgressBar1.Max = UBound(buffer) + 1
Frame1.Enabled = False
Dim tmp_result As String
tmp_result = ""
For i = 0 To UBound(buffer) Step 2
qh = buffer(i) - &HA0
wh = buffer(i + 1) - &HA0
offset = (94 * (qh - 1) + (wh - 1)) * bufferlength
Seek #1, offset + 1
Get #1, , tbuffer
k = 0
h = h + 1
tmp_result = tmp_result & "//" & Mid(Trim$(Text1.Text), h, 1) & vbCrLf
tmp_result = tmp_result & "{" & vbCrLf
For j = 0 To bufferlength - 1
If j <> bufferlength - 1 Then
If Hex(tbuffer(j)) < 10 Then
tmp_result = tmp_result & "0x0" & Hex(tbuffer(j)) & ","
Else
tmp_result = tmp_result & "0x" & Hex(tbuffer(j)) & ","
End If
k = k + 1
If k = 8 Then
tmp_result = tmp_result & vbCrLf
k = 0
End If
Else
If Hex(tbuffer(j)) < 10 Then
tmp_result = tmp_result & "0x0" & Hex(tbuffer(j))
Else
tmp_result = tmp_result & "0x" & Hex(tbuffer(j))
End If
tmp_result = tmp_result & vbCrLf
End If
Next
tmp_result = tmp_result & "}"
If i <> 0 And i Mod 30 = 0 Then
Text2.Text = Text2.Text & tmp_result & vbCrLf
tmp_result = ""
Else
tmp_result = tmp_result & vbCrLf & vbCrLf
End If
'Text2.Text = tmp_result & vbCrLf & vbCrLf
Form3.ProgressBar1.Value = i + 1
Form3.Show
Next
Close #1
Text2.Text = Text2.Text & tmp_result & vbCrLf & vbCrLf
Unload Form3
Frame1.Enabled = True
End Sub
Private Sub Text1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim count As Integer
count = 0
For icnt = 1 To Len(Trim(Me.Text1.Text))
Dim tmp_c As Integer
tmp_c = Asc(Mid(Text1.Text, icnt, 1))
If Not (tmp_c >= 0 And tmp_c < 128) Then
count = count + 1
End If
Next
If count <> 0 Then
Me.Text1.ToolTipText = "共有中文字符: " & count & " 个"
End If
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -