压缩文件超过521K，不能上传，到我的站上下载。
http://www.lshsoft.net/lshbbs/dispbbs.asp?boardID=23&ID=305&page=1

看见大家那么辛苦的寻找，把我的一个小东西发给大家参考参考。
感觉有用处就顶一下。

[此贴子已经被作者于2007-11-11 21:33:55编辑过]

Option Explicit
Public Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long
Public Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Public Declare Function ExitWindowsEx Lib "user32" (ByVal uFlages As Long, ByVal dwReserved As Long) As Long
Public Declare Function GetVolumeInformation Lib "kernel32" Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long
'**************终止Windows 95
Public Const gEWX_LOGOFF = 0 '所有进程被终止，并且用户退出登陆(LOGGED OFF)
Public Const gEWX_SHUTDOWN = 1 '计算机物理性关机
Public Const gEWX_BOOT = 2 '计算机关机后启动
Public Const gEWX_FORCE = 4 '所有进程被终止
Public Const gEWX_POWEROFF = 8 '节电状态
Public Const gEWX_RESET = 0 + 4 + 2 '计算机重新启动

'**************特殊符号
Public Const gstrNULL$ = "" ' 空字符串
Public Const gstrSEP_DIR$ = "\" ' 目录分隔符
Public Const gstrSEP_REGKEY$ = "\" ' 注册关键字分隔符
Public Const gstrSEP_DRIVE$ = ":" ' 驱动器分隔符,例如 C:\
Public Const gstrSEP_DIRALT$ = "/" ' 备用目录分隔符
Public Const gstrSEP_EXT$ = "." ' 文件扩展名分隔符
Public Const gstrSEP_PROGID = "."
Public Const gstrSEP_FILE$ = "|" ' 文件名列表中的分隔符，这是因为它在文件名中不是一个有效字符。
Public Const gstrSEP_LIST = "|"
Public Const gstrSEP_URL$ = "://" ' 在 URL 地址中接在 HPPT 之后的分隔符
Public Const gstrSEP_URLDIR$ = "/" ' 在 URL 地址中划分目录的分隔符。
Public Const gstrUNC$ = "\\" ' UNC 说明符 \\
Public Const gstrCOLON$ = ":"
Public Const gstrSwitchPrefix1 = "-"
Public Const gstrSwitchPrefix2 = "/"
Public Const gstrCOMMA$ = ","
Public Const gstrDECIMAL$ = "."
Public Const gstrQUOTE$ = """"
Public Const gstrCCOMMENT$ = "//" ' C 等语言中使用的注释说明符
Public Const gstrASSIGN$ = "="

'**************终止Windows 95
Public Const gintMAX_SIZE% = 255 ' 最大缓冲区大小
Public Const gintMAX_PATH_LEN% = 260 ' 所允许的最大路径长度，包括 NT (Intel) 和 Win95 的路径、文件名，
' 和命令行参数。
Public Const gintMAX_GROUPNAME_LEN% = 30 ' 所允许的 NT 3.51 组名的最大长度。
Public Const gintMIN_BUTTONWIDTH% = 1200
Public Const gsngBUTTON_BORDER! = 1.4

Public Const intDRIVE_REMOVABLE% = 2 ' GetDriveType 的常数
Public Const intDRIVE_FIXED% = 3
Public Const intDRIVE_REMOTE% = 4
Public Const intDRIVE_CDROM% = 5
Public Const intDRIVE_RAMDISK% = 6
'**************鼠标指针常数
Public Const gintMOUSE_DEFAULT% = 0
Public Const gintMOUSE_HOURGLASS% = 11

'=============关于SQL Server 全局变量====================Begin
Public gSqlServer As String
Public gSqlAdmin As String
Public gSqlPassWord As String
Public gSqlConnect As String
Public gDefaultDataBase As String
Public gConnect As ADODB.Connection
Public gConnectOk As Boolean
Public gRepFile As String
Public gSQLFile As String
Public gAppTitle As String
Public gMisPath As String
Public gSaveKh As String
Public gSaveGy As String
'=============关于SQL Server 全局变量====================End

'=============关于窗体按扭全局变量====================Begin
Public gButtonOk As Boolean
Public gButton As Boolean
Public gSaveOk As Boolean
Public gProgram As String

Public gMisLogin As Boolean
Public gMisUserID As String
Public gMisUserName As String
Public gMisUserQx As String
Public gPassWord As String

Public gAppDate As Date
Public gAppYear As String
Public gAppUser As String
'=============关于窗体按扭全局变量====================End
Public gKeMa00 As String
Public gKeMg00 As String
Public gKeMa01 As String
Public gKeMg01 As String
Public gKeMa02 As String
Public gKeMg02 As String

Public gYfYfId As String
Public gYfYfMc As String
Public gKsKsID As String
Public gKsKsMc As String
'=============关于工作日志变量====================End
Public gRzId As Long
Public gRzRz As String
Public gRzBg As String
Public gRzEd As String
Public gRzBz As String
'=============关于菜单变量====================Begin
Public gMenuNum As Integer

Public gFileRkRk As String
Public gFileSxSx As String
Public gFileKcKc As String
Public gFileKcJh As String
Public gFileKcPd As String
Public gFileGyGy As String
Public gFileGy01 As String
Public gFileGy02 As String
Public gFileKhKh As String
Public gFileKh01 As String
Public gFileKh02 As String
'----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
Public gRegOld As String
Public gRegNew As String
Public gRegOk As Boolean
Public gmax10 As Boolean
Public gNotReg As Boolean
Public gQuesstion As Integer
Public gPassShow As Integer

'----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------

'=============关于窗体按扭全局变量====================End
'-----------------------------------------------
'Private Sub Form_KeyPress(KeyAscii As Integer)
' If KeyAscii = 13 Then
' SendKeys "{Tab}"
' End If
'End Sub
'-----------------------------------------------

Sub Main()
gAppTitle = "临沂科成新型建材有限公司 - 发货端"
gAppUser = "临沂科成新型建材有限公司"
gAppDate = Date
If App.PrevInstance Then
Call Msg_Stop(gAppTitle & "已经运行 ！！！")
Exit Sub
End If
Call SaveGridString
gMisPath = App.Path
ChDir gMisPath
'------------------------------
gConnectOk = False
gSqlServer = "本地数据"
gSqlAdmin = ""
gSqlPassWord = ""
gDefaultDataBase = ""
'------------------------------
gSQLFile = gMisPath & "\NewJxc.Ini"
gDefaultDataBase = gMisPath & "\发货.软件"
DoEvents
Call ConnectSQlServer
gNotReg = False
If gConnectOk Then
DoEvents
Call ReadIni
gSqlServer = "本地数据"
Call Login
If gMisLogin Then
Load frmMain1
Call SetMenu
frmMain1.Caption = gAppTitle
frmMain1.Help_About.Caption = "关于“" & gAppTitle & "”(&A)..."
frmMain1.Show vbModal
Else
End
End If
Else
End
End If
End Sub

Sub Login()
gAppDate = Date
Load frmLogin
Dim ado用户列表 As ADODB.Recordset
Dim cSql As String
Set ado用户列表 = New ADODB.Recordset
ado用户列表.CursorType = adOpenDynamic
ado用户列表.LockType = adLockOptimistic
ado用户列表.CursorLocation = adUseClient
cSql = "Select * From [u0000_操作人员]"
ado用户列表.Open cSql, gConnect, , , adCmdText
If ado用户列表.RecordCount > 0 Then
ado用户列表.MoveFirst
Do While Not ado用户列表.EOF
frmLogin.cboID.AddItem GetFieldTxt(ado用户列表, "人码")
frmLogin.cboName.AddItem GetFieldTxt(ado用户列表, "人名")
frmLogin.CboPass.AddItem GetFieldTxt(ado用户列表, "口令")
ado用户列表.MoveNext
Loop
Else
cSql = "INSERT INTO [u0000_操作人员] (人码,人名,权限) VALUES " & _
"(" & _
"'Admin'," & _
"'超级用户'," & _
"'111111111111111' " & _
")"
gConnect.Execute cSql
frmLogin.cboID.AddItem "Admin"
frmLogin.cboName.AddItem "超级用户"
frmLogin.CboPass.AddItem ""

End If
ado用户列表.Close
Set ado用户列表 = Nothing
frmLogin.cboID.ListIndex = 0
frmLogin.cboName.ListIndex = 0
frmLogin.CboPass.ListIndex = 0
frmLogin.Show vbModal
If Not gMisLogin Then
End
End If
End Sub
Sub ZeroLengthField()
Dim ii As Currency
Dim jj As Currency
Dim wspDefault As DAO.Workspace
Dim dbs As DAO.Database
Dim tdf As DAO.TableDef
Dim fld As DAO.Field
Set wspDefault = DAO.DBEngine.Workspaces(0)
Set dbs = wspDefault.OpenDatabase(gDefaultDataBase, False)

For ii = 0 To dbs.TableDefs.Count - 1
Set tdf = dbs.TableDefs(ii)
For jj = 0 To tdf.Fields.Count - 1
Set fld = tdf.Fields(jj)
If UCase(Mid(tdf.Name, 1, 5)) = "U0000" Then
If (fld.Type = dbChar) Or (fld.Type = dbMemo) Or (fld.Type = dbText) Then
fld.AllowZeroLength = True
fld.DefaultValue = ""
End If
If fld.Type = dbCurrency Then
fld.DefaultValue = 0
End If
End If
Next jj
Next ii
dbs.Close
wspDefault.Close
End Sub

Sub CheckDataBase()
Dim cSql As String
Dim cTableName As String
'----------------------------------------------------------------
cTableName = "[u0000_操作人员]"
cSql = "Create Table " & cTableName & _
" ( " & _
" [人码] TEXT (20) ," & _
" [人名] TEXT (90) ," & _
" [口令] TEXT (20) ," & _
" [权限] TEXT (20) " & _
" ) "
gConnect.Execute cSql
cSql = "Create Index NewIndex On " & cTableName & " (人码)"
gConnect.Execute cSql
cSql = "INSERT INTO " & cTableName & " (人码,人名,权限) VALUES " & _
"(" & _
"'Admin'," & _
"'超级用户'," & _
"'111111111111111' " & _
")"
gConnect.Execute cSql
'----------------------------------------------------------------
cTableName = "[u0000_工作日志]"

cSql = "Create Table " & cTableName & _
" ( " & _
" [唯一] Counter ," & _
" [人码] TEXT (20) ," & _
" [人名] TEXT (20) ," & _
" [日期] TEXT (20) ," & _
" [内容] TEXT (90) " & _
" ) "
gConnect.Execute cSql
cSql = "Create Index NewIndex On " & cTableName & " (唯一)"
gConnect.Execute cSql
'-------------------------------------------------------------
cTableName = "[u0000_单据号码]"
cSql = "Create Table " & cTableName & _
" ( " & _
" [唯一] Counter ," & _
" [收货] TEXT (20) ," & _
" [付款] TEXT (20) " & _
" ) "
gConnect.Execute cSql
cSql = "Create Index NewIndex On " & cTableName & " (唯一)"
gConnect.Execute cSql
'-------------------------------------------------------------
cTableName = "[u0000_线路数据]"
cSql = "Create Table " & cTableName & _
" ( " & _
" [唯一] Counter ," & _
" [站点] TEXT (20) ," & _
" [标志] TEXT (20) " & _
" ) "
gConnect.Execute cSql
cSql = "Create Index NewIndex On " & cTableName & " (唯一)"
gConnect.Execute cSql
'-------------------------------------------------------------
cTableName = "[u0000_发货数据]"
cSql = "Create Table " & cTableName & _
" ( " & _
" [IDID] TEXT (20) ," & _
" [运单号] TEXT (20) ,[序号] TEXT (20) ," & _
" [发货单位] TEXT (90) ,[发货电话] TEXT (60) ,[发货地点] TEXT (60) ," & _
" [收货单位] TEXT (90) ,[收货电话] TEXT (60) ,[收货地点] TEXT (60) ," & _
" [起点] TEXT (20) ,[终点] TEXT (20) ,[编号] TEXT (20) ," & _
" [货物名称] TEXT (90) ,[规格] TEXT (90) ,[单位] TEXT (90) ," & _
" [发数量] Currency ,[发单价] Currency ,[发金额] Currency ," & _
" [收数量] Currency ,[收单价] Currency ,[收金额] Currency ," & _
" [发运费] Currency ,[收运费] Currency ," & _
" [收货日期] TEXT (20) ,[发货日期] TEXT (20) ," & _
" [收款日期] TEXT (20) ,[结算日期] TEXT (20) ," & _
" [导出日期] TEXT (20) ,[导入日期] TEXT (20) ," & _
" [C00] TEXT (20),[C01] TEXT (20),[C02] TEXT (20)," & _
" [N00] Currency ,[N01] Currency ,[N02] Currency ," & _
" [备注] TEXT (90) " & _
" ) "
gConnect.Execute cSql
cSql = "Create Index NewIndex On " & cTableName & " (IDID)"
gConnect.Execute cSql
'-------------------------------------------------------------
cTableName = "[u0000_备份数据]"
cSql = "Create Table " & cTableName & _
" ( " & _
" [IDID] TEXT (20) ," & _
" [运单号] TEXT (20) ,[序号] TEXT (20) ," & _
" [发货单位] TEXT (90) ,[发货电话] TEXT (60) ,[发货地点] TEXT (60) ," & _
" [收货单位] TEXT (90) ,[收货电话] TEXT (60) ,[收货地点] TEXT (60) ," & _
" [起点] TEXT (20) ,[终点] TEXT (20) ,[编号] TEXT (20) ," & _
" [货物名称] TEXT (90) ,[规格] TEXT (90) ,[单位] TEXT (90) ," & _
" [发数量] Currency ,[发单价] Currency ,[发金额] Currency ," & _
" [收数量] Currency ,[收单价] Currency ,[收金额] Currency ," & _
" [发运费] Currency ,[收运费] Currency ," & _
" [收货日期] TEXT (20) ,[发货日期] TEXT (20) ," & _
" [收款日期] TEXT (20) ,[结算日期] TEXT (20) ," & _
" [导出日期] TEXT (20) ,[导入日期] TEXT (20) ," & _
" [C00] TEXT (20),[C01] TEXT (20),[C02] TEXT (20)," & _
" [N00] Currency ,[N01] Currency ,[N02] Currency ," & _
" [备注] TEXT (90) " & _
" ) "
gConnect.Execute cSql
cSql = "Create Index NewIndex On " & cTableName & " (IDID)"
gConnect.Execute cSql
cTableName = "[u0000_货物代码]"
cSql = "Create Table " & cTableName & _
" ( " & _
" [IDID] TEXT (20) ," & _
" [编号] TEXT (20) ," & _
" [货物名称] TEXT (90) ,[规格] TEXT (90) ,[单位] TEXT (90) ," & _
" [单价一] Currency ,[单价二] Currency ,[单价三] Currency ," & _
" [C00] TEXT (20),[C01] TEXT (20),[C02] TEXT (20)," & _
" [N00] Currency ,[N01] Currency ,[N02] Currency ," & _
" [备注] TEXT (90) " & _
" ) "
gConnect.Execute cSql
cSql = "Create Index NewIndex On " & cTableName & " (编号)"
gConnect.Execute cSql

End Sub

'=============连接SQL Server
Sub ConnectSQlServer()
Err.Clear
On Error GoTo errhand
If Not FileExists(gDefaultDataBase) Then
'=====================================================================
Dim cSql As String
'-----------------------------------
Dim wspDefault As DAO.Workspace
Dim dbs As DAO.Database
Set wspDefault = DAO.DBEngine.Workspaces(0)
Set dbs = wspDefault.CreateDatabase(gDefaultDataBase, dbLangGeneral)
dbs.Close
wspDefault.Close
'-----------------------------------
Set dbs = Nothing
Set wspDefault = Nothing
'-----------------------------------
gSqlConnect = "Provider=Microsoft.Jet.OLEDB.3.51;Persist Security Info=False;Data Source=" & gDefaultDataBase
Set gConnect = New ADODB.Connection
gConnect.CommandTimeout = 3600
gConnect.Open gSqlConnect
gConnectOk = True

Call CheckDataBase
gConnect.Close
Call ZeroLengthField
'=====================================================================
Call Msg_Info("第一次使用，数据库创建完毕，需要重新运行程序，超级用户的口令为空。")
End
End If

gSqlConnect = "Provider=Microsoft.Jet.OLEDB.3.51;Persist Security Info=False;Data Source=" & gDefaultDataBase
Set gConnect = New ADODB.Connection
gConnect.CommandTimeout = 3600
gConnect.Open gSqlConnect
gConnectOk = True
Exit Sub
errhand:
Call Msg_Stop("数据库连接失败！！！")
End
End Sub
Sub ReadIni()
Dim lpApplicationName As String
Dim lpKeyName As String
Dim lpDefault As String
Dim lpReturnedString As String
Dim nSize As Long
Dim lpFileName As String

lpApplicationName = "RunEvent"
lpKeyName = "SQL_SERVER"
lpDefault = Space(250)
lpReturnedString = Space(250)
nSize = 250
lpFileName = gSQLFile
GetPrivateProfileString lpApplicationName, lpKeyName, lpDefault, lpReturnedString, nSize, lpFileName
gSqlServer = StripTerminator(lpReturnedString)

lpApplicationName = "RunEvent"
lpKeyName = "SQL_ID"
lpDefault = Space(250)
lpReturnedString = Space(250)
nSize = 250
lpFileName = gSQLFile
GetPrivateProfileString lpApplicationName, lpKeyName, lpDefault, lpReturnedString, nSize, lpFileName
gSqlAdmin = StripTerminator(lpReturnedString)

lpApplicationName = "RunEvent"
lpKeyName = "SQL_PASSWORD"
lpDefault = Space(250)
lpReturnedString = Space(250)
nSize = 250
lpFileName = gSQLFile
GetPrivateProfileString lpApplicationName, lpKeyName, lpDefault, lpReturnedString, nSize, lpFileName
gSqlPassWord = StripTerminator(lpReturnedString)

lpApplicationName = "RunEvent"
lpKeyName = "SQL_DATABASE"
lpDefault = Space(250)
lpReturnedString = Space(250)
nSize = 250
lpFileName = gSQLFile
GetPrivateProfileString lpApplicationName, lpKeyName, lpDefault, lpReturnedString, nSize, lpFileName
gKsKsID = StripTerminator(lpReturnedString)


lpApplicationName = "RunEvent"
lpKeyName = "Product ID"
lpDefault = Space(250)
lpReturnedString = Space(250)
nSize = 250
lpFileName = gSQLFile
GetPrivateProfileString lpApplicationName, lpKeyName, lpDefault, lpReturnedString, nSize, lpFileName
gRegOld = StripTerminator(lpReturnedString)

lpApplicationName = "RunEvent"
lpKeyName = "AppUserName"
lpDefault = Space(250)
lpReturnedString = Space(250)
nSize = 250
lpFileName = gSQLFile
GetPrivateProfileString lpApplicationName, lpKeyName, lpDefault, lpReturnedString, nSize, lpFileName
gAppUser = StripTerminator(lpReturnedString)

If Is_Empty(gAppUser) Then
gAppUser = "临沂科成新型建材有限公司"
End If

lpApplicationName = "供应商"
lpKeyName = "Save"
lpDefault = Space(250)
lpReturnedString = Space(250)
nSize = 250
lpFileName = gSQLFile
GetPrivateProfileString lpApplicationName, lpKeyName, lpDefault, lpReturnedString, nSize, lpFileName
gSaveGy = StripTerminator(lpReturnedString)
If Is_Empty(gSaveGy) Then
gSaveGy = "Yes"
End If
lpApplicationName = "客户"
lpKeyName = "Save"
lpDefault = Space(250)
lpReturnedString = Space(250)
nSize = 250
lpFileName = gSQLFile
GetPrivateProfileString lpApplicationName, lpKeyName, lpDefault, lpReturnedString, nSize, lpFileName
gSaveKh = StripTerminator(lpReturnedString)
If Is_Empty(gSaveKh) Then
gSaveGy = "Yes"
End If

End Sub

'=============回答Yes Or No
Function Msg_Yes(MESS As String) As Boolean
If MsgBox(MESS, 36, "提示") = 6 Then
Msg_Yes = True
Else
Msg_Yes = False
End If
End Function

'=============提示信息
Function Msg_Info(MESS As String)
MsgBox MESS, 64, "信息"
End Function

'=============警告信息
Function Msg_Stop(MESS As String)
MsgBox MESS, 16, "警告"
End Function

'=============判断字符串是否空
Function Is_Empty(MESS As String) As Boolean
If Len(Trim(MESS)) = 0 Then
Is_Empty = True
Else
Is_Empty = False
End If
End Function

'-----------------------------------------------------------
' 函数: FileExists
' 判断是否存在指定的文件
'
' 入口: [strPathName] - 要检查的文件
'
' 返回: True，如果文件存在；否则为 False
'-----------------------------------------------------------
'
Function FileExists(ByVal strPathName As String) As Boolean
Dim intFileNum As Integer

On Error Resume Next

'
' 如果引用了字符串，删除引用
'
strPathName = strUnQuoteString(strPathName)
'
'删除所有尾随的目录分隔符
'
If Right$(strPathName, 1) = gstrSEP_DIR Then
strPathName = Left$(strPathName, Len(strPathName) - 1)
End If

'
'试图打开文件，本函数的返回值为 False
'如果打开时出错，否则为 True
'
intFileNum = FreeFile
Open strPathName For Input As intFileNum

FileExists = IIf(Err = 0, True, False)

Close intFileNum

Err = 0
End Function

Function strUnQuoteString(ByVal strQuotedString As String) As String
'
' 本子程序测试 strQuotedString 是否在引号中折行，如果是，删除之。
'
strQuotedString = Trim(strQuotedString)

If Mid$(strQuotedString, 1, 1) = gstrQUOTE And Right$(strQuotedString, 1) = gstrQUOTE Then
'
' 如果有引号，去掉引号。
'
strQuotedString = Mid$(strQuotedString, 2, Len(strQuotedString) - 2)
End If
strUnQuoteString = strQuotedString
End Function

'-----------------------------------------------------------
' 函数: StripTerminator
'
' 返回非零结尾的字符串。典型地，这是一个由 Windows API 调用返回的字符串。
'
' 入口: [strString] - 要删除结束符的字符串
'
' 返回: 传递的字符串减去尾部零以后的值。
'-----------------------------------------------------------
'
Function StripTerminator(ByVal strString As String) As String
Dim intZeroPos As Integer

intZeroPos = InStr(strString, Chr$(0))
If intZeroPos > 0 Then
StripTerminator = Left$(strString, intZeroPos - 1)
Else
StripTerminator = strString
End If
End Function

'=============取文本
Function GetFieldTxt(cTableName As ADODB.Recordset, cFieldName As String) As String
On Error GoTo errhand
If cTableName.AbsolutePosition > 0 Then
If cTableName.RecordCount > 0 Then
GetFieldTxt = IIf(IsNull(cTableName.Fields(cFieldName)), "", cTableName.Fields(cFieldName))
Else
GetFieldTxt = ""
End If
GetFieldTxt = Trim(GetFieldTxt)
End If
Exit Function
errhand:
GetFieldTxt = ""
Call Msg_Stop("对应的记录已经不存在！！！")
End Function

'=============取数值
Function GetFieldNum(cTableName As ADODB.Recordset, cFieldName As String) As Currency
On Error GoTo errhand
If cTableName.AbsolutePosition > 0 Then
If cTableName.RecordCount > 0 Then
GetFieldNum = IIf(IsNull(cTableName.Fields(cFieldName)), 0, cTableName.Fields(cFieldName))
Else
GetFieldNum = 0
End If
End If
Exit Function
errhand:
GetFieldNum = 0
Call Msg_Stop("对应的记录已经不存在！！！")
End Function

'=============取数值但转化为文本
Function GetFieldN2T(cTableName As ADODB.Recordset, cFieldName As String) As String
On Error GoTo errhand
If cTableName.AbsolutePosition > 0 Then
If cTableName.RecordCount > 0 Then
GetFieldN2T = Str(IIf(IsNull(cTableName.Fields(cFieldName)), 0, cTableName.Fields(cFieldName)))
Else
GetFieldN2T = "0"
End If
GetFieldN2T = Trim(GetFieldN2T)
If GetFieldN2T = "0" Then
GetFieldN2T = ""
End If
GetFieldN2T = Format(GetFieldN2T, "###########0.00")
End If
Exit Function
errhand:
GetFieldN2T = ""
Call Msg_Stop("对应的记录已经不存在！！！")
End Function

'*********************************************
'*函数用途：人民币金额大写转换
'*函数参数：人民币金额 NUM （数值）
'*函数返回：人民币大写 STRING （字符）
'*********************************************
Function jedxzh(num As Currency) As String
On Error GoTo ErrTxt
Dim NUMBER As String
Dim monetary As String
Dim cstring As String
Dim flag As Boolean
Dim cp As String
Dim ij As Integer
Dim nLen As Integer
Dim Fh As String
cstring = ""
Fh = ""
NUMBER = "零壹贰叁肆伍陆柒捌玖"
monetary = "万仟佰拾亿仟佰拾万仟佰拾元角分"
If num = 0 Then
cstring = "零元整"
Else
If num < 0 Then
Fh = "负"
num = (-1) * num
End If
flag = True
cp = Trim(Str(num))
nLen = InStr(cp, ".")
If nLen = 0 Then
cp = cp + ".00"
Else
cp = Mid(cp, 1, nLen + 2)
End If
num = Val(cp)
cp = Trim(Str(num * 100))
cp = Space(15 - Len(cp)) + cp + "|"
For ij = 1 To 15
If Mid(cp, ij, 1) = "|" Then
Exit For
End If
If Val(Mid(cp, ij, 1)) <> 0 Then
cstring = cstring & Mid(NUMBER, Val(Mid(cp, ij, 1)) + 1, 1)
cstring = cstring & Mid(monetary, ij, 1)
Else
If ij = 6 Then
If Val(Mid(cp, ij, 4)) = 0 Then
cstring = cstring + ""
flag = False
End If
End If
If ij = 13 Or (ij = 9 And flag) Or ij = 5 Then
If Not Is_Empty(cstring) Then
cstring = cstring & Mid(monetary, ij, 1)
End If
End If
If Val(Mid(cp, ij + 1, 1)) <> 0 And Mid(cp, ij + 1, 1) <> "|" Then
If Not Is_Empty(cstring) Then
cstring = cstring + "零"
End If
End If
End If
Next ij

If Val(Mid(cp, ij - 1, 1)) = 0 Then
cstring = cstring + "整"
End If
End If
cstring = Fh & cstring
jedxzh = cstring
Exit Function
ErrTxt:
Call Msg_Info("金额太大,最大金额只能达到万亿级")
End Function

'*********************************************
'*函数用途：日期大写转换
'*函数参数：日期 sj 日期型，wymd 字符型'YMD'
'*函数返回：日期大写 csj （字符）
'*********************************************
Function rqdxzh(sj As Date, wymd As String) As String

Dim Msj As Date
Dim Dx As String
Dim mYear As String
Dim mMonth As Integer
Dim mDay As Integer
Dim csj As String
Dim ii As Integer
Dim AAA As String
Dim D1 As String
Dim D2 As String
Dim D3 As String
wymd = UCase(Trim(wymd))
Msj = Format(sj, "YYYY-MM-DD")
Dx = "○一二三四五六七八九十"
mYear = Trim(Str(Year(Msj)))
csj = ""
ii = 1

Do While ii < 5
AAA = Mid(mYear, ii, 1) + 1
csj = csj & Mid(Dx, Val(AAA), 1)
ii = ii + 1
Loop
csj = csj + "年"
D1 = csj

csj = ""
mMonth = Month(Msj)
If mMonth < 11 Then
csj = Mid(Dx, mMonth + 1, 1)
Else
csj = "十" & Mid(Dx, mMonth - 10 + 1, 1)
End If
csj = csj + "月"
D2 = csj

csj = ""

mDay = Day(Msj)
If mDay < 11 Then
csj = Mid(Dx, mDay + 1, 1)
End If

If mDay >= 11 And mDay < 20 Then
csj = "十"
csj = csj & Mid(Dx, mDay - 10 + 1, 1)
End If
If mDay = 20 Then
csj = "二十"
End If

If mDay >= 21 And mDay < 30 Then
csj = "二十"
csj = csj & Mid(Dx, mDay - 20 + 1, 1)
End If
If mDay = 30 Then
csj = "三十"
End If

If mDay >= 31 And mDay < 40 Then
csj = "三十"
csj = csj & Mid(Dx, mDay - 30 + 1, 1)
End If

csj = csj & "日"
D3 = csj
Select Case wymd
Case "Y"
rqdxzh = D1
Case "YM"
rqdxzh = D1 & D2
Case "YMD"
rqdxzh = D1 & D2 & D3
Case Else
rqdxzh = D1 & D2 & D3
End Select
End Function

Function NumToText(dblVal As Double) As String
Static Ones(0 To 9) As String
Static Teens(0 To 9) As String
Static Tens(0 To 9) As String
Static Thousands(0 To 4) As String
Static bInit As Boolean
Dim i As Integer, bAllZeros As Boolean, bShowThousands As Boolean
Dim strVal As String, strBuff As String, strTemp As String
Dim ncol As Integer, nChar As Integer

'Only handles positive values
Debug.Assert dblVal >= 0

If bInit = False Then
'Initialize array
bInit = True
Ones(0) = "zero"
Ones(1) = "one"
Ones(2) = "two"
Ones(3) = "three"
Ones(4) = "four"
Ones(5) = "five"
Ones(6) = "six"
Ones(7) = "seven"
Ones(8) = "eight"
Ones(9) = "nine"
Teens(0) = "ten"
Teens(1) = "eleven"
Teens(2) = "twelve"
Teens(3) = "thirteen"
Teens(4) = "fourteen"
Teens(5) = "fifteen"
Teens(6) = "sixteen"
Teens(7) = "seventeen"
Teens(8) = "eighteen"
Teens(9) = "nineteen"
Tens(0) = ""
Tens(1) = "ten"
Tens(2) = "twenty"
Tens(3) = "thirty"
Tens(4) = "forty"
Tens(5) = "fifty"
Tens(6) = "sixty"
Tens(7) = "seventy"
Tens(8) = "eighty"
Tens(9) = "ninety"
Thousands(0) = ""
Thousands(1) = "thousand" 'US numbering
Thousands(2) = "million"
Thousands(3) = "billion"
Thousands(4) = "trillion"
End If
'Trap errors
On Error GoTo NumToTextError
'Get fractional part
strBuff = "and " & Format((dblVal - Int(dblVal)) * 100, "00") & "/100"
'Convert rest to string and process each digit
strVal = CStr(Int(dblVal))
'Non-zero digit not yet encountered
bAllZeros = True
'Iterate through string
For i = Len(strVal) To 1 Step -1
'Get value of this digit
nChar = Val(Mid$(strVal, i, 1))
'Get column position
ncol = (Len(strVal) - i) + 1
'Action depends on 1's, 10's or 100's column
Select Case (ncol Mod 3)
Case 1 '1's position
bShowThousands = True
If i = 1 Then
'First digit in number (last in loop)
strTemp = Ones(nChar) & " "
ElseIf Mid$(strVal, i - 1, 1) = "1" Then
'This digit is part of "teen" number
strTemp = Teens(nChar) & " "
i = i - 1 'Skip tens position
ElseIf nChar > 0 Then
'Any non-zero digit
strTemp = Ones(nChar) & " "
Else
'This digit is zero. If digit in tens and hundreds column
'are also zero, don't show "thousands"
bShowThousands = False
'Test for non-zero digit in this grouping
If Mid$(strVal, i - 1, 1) <> "0" Then
bShowThousands = True
ElseIf i > 2 Then
If Mid$(strVal, i - 2, 1) <> "0" Then
bShowThousands = True
End If
End If
strTemp = ""
End If
'Show "thousands" if non-zero in grouping
If bShowThousands Then
If ncol > 1 Then
strTemp = strTemp & Thousands(ncol \ 3)
If bAllZeros Then
strTemp = strTemp & " "
Else
strTemp = strTemp & ", "
End If
End If
'Indicate non-zero digit encountered
bAllZeros = False
End If
strBuff = strTemp & strBuff
Case 2 '10's position
If nChar > 0 Then
If Mid$(strVal, i + 1, 1) <> "0" Then
strBuff = Tens(nChar) & "-" & strBuff
Else
strBuff = Tens(nChar) & " " & strBuff
End If
End If
Case 0 '100's position
If nChar > 0 Then
strBuff = Ones(nChar) & " hundred " & strBuff
End If
End Select
Next i
'Convert first letter to upper case
strBuff = UCase$(Left$(strBuff, 1)) & Mid$(strBuff, 2)
EndNumToText:
'Return result
NumToText = strBuff
Exit Function
NumToTextError:
strBuff = "#Error#"
Resume EndNumToText
End Function

Function GetOnlyOneFph()
GetOnlyOneFph = Format(Now, "YYYYMMDDhhmmss") & Mid(Trim(Str(Int(Rnd * 10000))), 2, 3)
End Function
Sub FileLogin()
Call Login
Call SetMenu
End Sub

Sub FileLogout()
gMisUserID = ""
gMisUserName = ""
gMisLogin = False
Call SetMenu
End Sub
Sub SetMenu()
frmMain1.File_Login.Enabled = Not gMisLogin
frmMain1.File_Logout.Enabled = gMisLogin
frmMain1.File_PassWord.Enabled = gMisLogin
frmMain1.File_SetPrint.Enabled = gMisLogin
frmMain1.GZFG.Enabled = gMisLogin
frmMain1.XlWh.Enabled = gMisLogin
frmMain1.edit_add.Enabled = gMisLogin
frmMain1.edit_EDIT.Enabled = gMisLogin
frmMain1.edit_DELE.Enabled = gMisLogin
frmMain1.edit_FIND.Enabled = gMisLogin
' frmMain1.edit_SUM.Enabled = gMisLogin
frmMain1.edit_PRINT.Enabled = gMisLogin
frmMain1.edit_GjZf.Enabled = gMisLogin
frmMain1.Toolbar1.Buttons(1).Enabled = Not gMisLogin
frmMain1.Toolbar1.Buttons(2).Enabled = gMisLogin
frmMain1.Toolbar1.Buttons(3).Enabled = gMisLogin

frmMain1.Toolbar1.Buttons(5).Enabled = gMisLogin
frmMain1.Toolbar1.Buttons(6).Enabled = gMisLogin
frmMain1.Toolbar1.Buttons(7).Enabled = gMisLogin
frmMain1.Toolbar1.Buttons(8).Enabled = gMisLogin
frmMain1.Toolbar1.Buttons(10).Enabled = gMisLogin
frmMain1.Toolbar1.Buttons(12).Enabled = gMisLogin
frmMain1.Toolbar1.Buttons(14).Enabled = gMisLogin

frmMain1.StatusBar1.Panels(1).Text = gSqlServer
frmMain1.StatusBar1.Panels(2).Text = gMisUserName
frmMain1.StatusBar1.Panels(3).Text = Format(gAppDate, "YYYY-MM-DD")
End Sub

Sub FilePassWord()
frmPassWord.Show vbModal
End Sub
Sub FileSetPrint()
On Error GoTo printerr
frmMain1.CommonDialog1.Flags = &H40
frmMain1.CommonDialog1.ShowPrinter
Exit Sub
printerr:

End Sub

Sub FileExit()
Unload frmMain1
End Sub

以上仅是主模块代码部分,感觉对自己有用就下载吧,别忘了顶一下,给我力量.

好东西竟然没有人顶，还要到处求助．郁闷！

程序浩浩荡荡啊，收下了，辛苦了，lz

谢谢！就是注释少了点

顺便问一个问题：怎么在MSHFlexGrid1新加一行记录啊？我写了一段，但老是提示下标越界，代码如下：
Private Sub Command1_Click()

tushubianhao = Text1.Text
tushumingcheng = Text3.Text
zuozhexingming = Text5.Text
chubanshe = Text7.Text
chubanriqi = Text2.Text
tushudanjia = Text4.Text
tushuleibie = Text6.Text

If tushumingcheng = "" Then
MsgBox "请输入图书名称！", vbOKOnly
End If
If tushubianhao = "" Then
MsgBox "请输入图书编号！", vbOKOnly
End If
If zuozhexingming = "" Then
MsgBox "请输入作者姓名！", vbOKOnly
End If
If chubanshe = "" Then
MsgBox "请输入出版社！", vbOKOnly
End If
If chubanriqi = "" Then
MsgBox "请输入出版日期！", vbOKOnly
End If
If tushudanjia = "" Then
MsgBox "请输入图书单价！", vbOKOnly
End If
If tushuleibie = "" Then
MsgBox "请输入图书类别！", vbOKOnly
End If

Dim cn As New ADODB.Connection
Dim BookRec As New ADODB.Recordset
Dim BookSql As String
BookSql = "select * from 图书目录"
cn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\Documents and Settings\jjz\桌面\陈良勇\图书馆\BOOK.MDB;Persist Security Info=False"
cn.Open
BookRec.Open BookSql, cn, adOpenKeyset, adLockOptimistic
With BookRec
.AddNew
.Fields("图书编号") = tushubianhao
.Fields("图书名称") = tushumingcheng
.Fields("作者姓名") = zuozhexingming
.Fields("出版社") = chubanshe
.Fields("出版日期") = chubanriqi
.Fields("图书单价") = tushudanjia
.Fields("图书类别") = tushuleibie
.Update
.Close
End With

With MSHFlexGrid1

.Rows = .Rows + 1
.TextMatrix(tushubianhao + 1, 0) = tushubianhao
.TextMatrix(tushubianhao + 1, 1) = tushumingcheng
.TextMatrix(tushubianhao + 1, 2) = zuozhexingming
.TextMatrix(tushubianhao + 1, 3) = chubanshe
.TextMatrix(tushubianhao + 1, 4) = chubanriqi
.TextMatrix(tushubianhao + 1, 5) = tushudanjia
.TextMatrix(tushubianhao + 1, 6) = tushuleibie
End With

MsgBox "图书目录增加成功！", vbOKOnly
Text1.Text = Text1.Text + 1
Text2.Text = ""
Text3.Text = ""
Text4.Text = ""
Text5.Text = ""
Text6.Text = ""
Text7.Text = ""
MSHFlexGrid1.Refresh

End Sub