VB 自动读取中文首字母并自动写入数据库

'读取单个汉字的首字母

Public Function getPYChar(char As String) As String

Dim lChar As Long

lChar = 65536 + Asc(char)

If (lChar >= 45217 And lChar <= 45252) Then getPYChar = "A"

If (lChar >= 45253 And lChar <= 45760) Then getPYChar = "B"

If (lChar >= 47761 And lChar <= 46317) Then getPYChar = "C"

If (lChar >= 46318 And lChar <= 46825) Then getPYChar = "D"

If (lChar >= 46826 And lChar <= 47009) Then getPYChar = "E"

If (lChar >= 47010 And lChar <= 47296) Then getPYChar = "F"

If (lChar >= 47297 And lChar <= 47613) Then getPYChar = "G"

If (lChar >= 47614 And lChar <= 48118) Then getPYChar = "H"

If (lChar >= 48119 And lChar <= 49061) Then getPYChar = "J"

If (lChar >= 49062 And lChar <= 49323) Then getPYChar = "K"

If (lChar >= 49324 And lChar <= 49895) Then getPYChar = "L"

If (lChar >= 49896 And lChar <= 50370) Then getPYChar = "M"

If (lChar >= 50371 And lChar <= 50613) Then getPYChar = "N"

If (lChar >= 50614 And lChar <= 50621) Then getPYChar = "O"

If (lChar >= 50622 And lChar <= 50905) Then getPYChar = "P"

If (lChar >= 50906 And lChar <= 51386) Then getPYChar = "Q"

If (lChar >= 51387 And lChar <= 51445) Then getPYChar = "R"

If (lChar >= 51446 And lChar <= 52217) Then getPYChar = "S"

If (lChar >= 52218 And lChar <= 52697) Then getPYChar = "T"

If (lChar >= 52698 And lChar <= 52979) Then getPYChar = "W"

If (lChar >= 52980 And lChar <= 53640) Then getPYChar = "X"

If (lChar >= 53689 And lChar <= 54480) Then getPYChar = "Y"

If (lChar >= 54481 And lChar <= 52289) Then getPYChar = "Z"

End Function

'读取汉字字符串的所有首字母

Public Function getPY(str As String) As String

For i = 0 To Len(str) - 1

getPY = getPY &getPYChar(Mid(str, i + 1, 1))

Next

End Function

开始写入数据:

连接数据库,我就不说了

rs.open "select * from 文字表",conn,1,1

rs.movefirst

do while not rs.eof

rs("字段2")=getPY(rs("字段1"))

loop

rs.update

rs.close

程序已发到你的邮箱,请查收

简单说一下：

1、你的数据库里用中文名称，这个不太好，虽然大部分没有问题，但有时会有问题出现...建议改为英文或首字拼单为好；

2、查询时应该要选择是否进行查询，如果没有输入的，不需要进行查询，登记日期前应该加一个钩选的选项，不钩选不进行查询，改为：

Dim s as string

s = "Select * form SIMcard where 1=1 "

if len(trim(text1))>0 then s = s &"and spname like '" &text1 &"' " ‘商户名称

if len(trim(text2))>0 then s = s &"and spid like '" &text2 &"' " ‘商户号

......

最后才是 Adodc1.RecordSource= s

然后Adodc1.Refresh

3、从你查询出错来看，应该是查询前数据库关闭或查询出错，DataGrid1没有绑定Adodc1数据，引起的没有结果，建议把程序附上，光看一部分不一定能判断出问题。

绑定数据源：

set datagrid1.datasource=adodc1

这个你将就一下，或许别人还有更好的办法：

参数为数值，返回二进制字符串

Function Bit(value) As String

Dim m

m = Val(value)

Dim BitStr As String

BitStr = String(Len(Hex(m)) * 4, "0") '初始字符串长度，初始值为"0" ，"0"可以改为"否"

Dim i As Integer

Dim bLoc As Long

bLoc = 1

For i = 1 To Len(BitStr) '扫描每个位

    If m And bLoc Then Mid(BitStr, i) = "1"   ' "1"可以改为"是" 。对每个位按位与来判断是1 或 0

    bLoc = bLoc * 2

Next

Bit = BitStr

End Function

---