module1.bas

windows mobile 应用程序开发实践一书的源代码

Attribute VB_Name = "Module"
Option Explicit
Dim tableid As Long
Dim stablename, newfield, luxfield As String
Dim indexnum, totalfields, tem As Integer
Public fieldnamearray(9) As String
Dim Connection As ADOCE.Connection
Dim table, indextable As ADOCE.Recordset
Set Connection = CreateObject("ADOCE.Connection.3.1")
Set table = CreateObject("ADOCE.Recordset.3.1")
Set indextable = CreateObject("ADOCE.Recordset.3.1")
indextable.cursortype = adOpenKeyset
indextable.locktype = adLockOptimistic
Connection.Open "" & App.Path & "\delivery.cdb"
table.Open "detail", Connection, adOpenKeyset, adLockOptimistic
Dim globestr As String
Private Sub addnewdata(xx As Object, tableobj As Object)

 If Not tableobj.Supports(adAddNew) Then
 Exit Sub
 End If
 tableobj.AddNew

       
      tableobj.fields.Item("商品编码").Value = xx.tx_shbianma.Text
      tableobj.fields.Item("商品名称").Value = xx.tx_mincheng.Text
      tableobj.fields.Item("商品条码").Value = xx.tx_tiaoma.Text
      tableobj.fields.Item("商品价格").Value = CDbl(Trim(xx.tx_jiage.Text))
      tableobj.fields.Item("商品规格").Value = xx.tx_guige.Text
     
      tableobj.update
      tableobj.Requery
 
End Sub

Public Sub enablefields(xx As Object)


 
  xx.tx_shbianma.enabled = True
  xx.tx_tiaoma.enabled = True
  xx.tx_mincheng.enabled = True
  xx.tx_jiage.enabled = True
  xx.tx_guige.enabled = True

  
End Sub
Public Sub clearfields(xx As Object)

 
  xx.tx_shbianma.Text = ""
  xx.tx_mincheng.Text = ""
  xx.tx_tiaoma.Text = ""
  xx.tx_jiage.Text = ""
  xx.tx_guige.Text = ""
 

End Sub
Public Sub disablefields(xx As Object)
   
   
 
  xx.tx_shbianma.enabled = False
  xx.tx_mincheng.enabled = False
  xx.tx_tiaoma.enabled = False
  xx.tx_jiage.enabled = False
  xx.tx_guige.enabled = False
  


End Sub
Public Sub showfields(xx As Object, tableobj As Object)

   xx.tx_shbianma.Text = ridnull(tableobj.fields.Item("商品编码").Value)
  xx.tx_mincheng.Text = ridnull(tableobj.fields.Item("商品名称").Value)
  xx.tx_tiaoma.Text = ridnull(tableobj.fields.Item("商品条码").Value)
  xx.tx_jiage.Text = tableobj.fields.Item("商品价格").Value
  xx.tx_guige.Text = ridnull(tableobj.fields.Item("商品规格").Value)
 
End Sub


Public Sub updatefields(xx As Object, tableobj As Object)

 
      tableobj.fields.Item("商品编码").Value = xx.tx_shbianma.Text
      tableobj.fields.Item("商品名称").Value = xx.tx_mincheng.Text
      tableobj.fields.Item("商品条码").Value = xx.tx_tiaoma.Text
      tableobj.fields.Item("商品价格").Value = CDbl(Trim(xx.tx_jiage.Text))
      tableobj.fields.Item("商品规格").Value = xx.tx_guige.Text
      

End Sub
Private Sub xiugai(xx As Object, tableobj As Object)

If Not tableobj.Supports(adUpdate) Then
MsgBox "不支持更新", vbOKOnly, "提醒"
Exit Sub
End If
 
      tableobj.fields.Item("商品编码").Value = xx.tx_shbianma.Text
      tableobj.fields.Item("商品名称").Value = xx.tx_mincheng.Text
      tableobj.fields.Item("商品条码").Value = xx.tx_tiaoma.Text
      tableobj.fields.Item("商品价格").Value = CDbl(Trim(xx.tx_jiage.Text))
      tableobj.fields.Item("商品规格").Value = xx.tx_guige.Text
      
  
End Sub
Private Function openandshowindexrecord(ByVal xx As Object, tableobj As Object, ByVal recindex As Integer)

 If table.State = adStateClosed Then
 table.Open "detail", Connection, adOpenKeyset, adLockOptimistic
 End If
 showallfieldshasarray (xx)
 'totalfields = getarraytotal()
 If tableobj.State = adStateClosed Then
 tableobj.Open
 End If
 If Not (tableobj.BOF And tableobj.EOF) Then
 tableobj.Move indexnum, 1
 showfields xx, tableobj
 xx.but_dakai.enabled = False
 xx.but_zenjia.enabled = True
 xx.but_xiugai.enabled = True
 xx.but_shanchu.enabled = True
 movex xx, True
 xx.but_dakai.enabled = False
 xx.but_zenjia.enabled = True
 xx.but_xiugai.enabled = True
 xx.but_shanchu.enabled = True
 movex xx, True
 enablefields (xx)
 End If
 
End Function
Private Function openandshowindexrecordfrm(ByVal xx As Object, tableobj As Object, ByVal recindex As Integer)

 If table.State = adStateClosed Then
 table.Open "detail", Connection, adOpenKeyset, adLockOptimistic
 End If
 showallfieldshasarray (xx)
 'totalfields = getarraytotal()
 If tableobj.State = adStateClosed Then
 tableobj.Open
 End If
 If Not (tableobj.BOF And tableobj.EOF) Then
 tableobj.Move indexnum, 1
 showfields xx, tableobj
 End If
 
End Function
Private Sub move2jieshu(xx As Object)

If table.State = adStateClosed Then
table.Open
End If
If table.BOF And table.EOF Then
MsgBox "没有记录，不能再移动", vbOKOnly, "提醒"
Exit Sub
End If

table.movelast

showfields xx, table
xx.but_zenjia.enabled = True
 
End Sub

Private Sub move2first(xx As Object)

If table.State = adStateClosed Then
table.Open
End If

If table.BOF And table.EOF Then
MsgBox "没有记录，不能再移动", vbOKOnly, "提醒"
Exit Sub
End If
table.MoveFirst
showfields xx, table
xx.but_zenjia.enabled = True
 
End Sub

Private Sub move2xiayitiao(xx As Object)

If table.State = adStateClosed Then
table.Open
End If

If table.BOF And table.EOF Then
MsgBox "没有记录，不能再移动", vbOKOnly, "提醒"
Exit Sub
End If

table.MoveNext
If table.EOF Then
MsgBox "最后一条，不能再移动", vbOKOnly, "提醒"
'MsgBox "最后一条，不能再移动"
table.movelast
End If
showfields xx, table
xx.but_zenjia.enabled = True
 
End Sub

Private Sub move2qianyitiao(xx As Object)

If table.State = adStateClosed Then
table.Open
End If
If table.BOF And table.EOF Then
MsgBox "没有记录，不能再移动", vbOKOnly, "提醒"
Exit Sub
End If

table.MovePrevious
If table.BOF Then
MsgBox "已经是第一条，不能再移动", vbOKOnly, "提醒"
table.MoveFirst
xx.but_zenjia.enabled = True
End If
showfields xx, table

End Sub
Private Sub addnewrecord(xx As Object)

If table.editmode = adEditInProgress Then
updatefields xx
Else
addnewdata xx, table
End If
showfields xx, table
disablefields (xx)
movex xx, True
xx.but_zenjia.enabled = False
xx.but_chongxie.enabled = False
xx.but_quxiao.enabled = False
 
End Sub
Public Sub movex(xx As Object, enabled As Boolean)

If enabled Then
xx.but_first.enabled = True
xx.but_next.enabled = True
xx.but_previous.enabled = True
xx.but_end.enabled = True
Else
xx.but_first.enabled = False
xx.but_next.enabled = False
xx.but_previous.enabled = False
xx.but_end.enabled = False
End If

End Sub
Private Sub quxiao(xx As Object)

If table.editmode = adEditInProgress Then
table.CancelUpdate
table.MovePrevious
table.MoveNext
showfields xx, table
xx.but_zenjia.Caption = "增加"
Else
clearfields (xx)
End If
xx.but_chongxie.enabled = False
xx.but_quxiao.enabled = False
 movex xx, True
disablefields (xx)

End Sub

Private Sub shanchu(xx As Object, tableobj As Object)

 Dim yesorno As Integer
 If tableobj.Supports(adDelete) Then
 yesorno = MsgBox("是否将屏幕上数据删除?", vbOKCancel + vbCritical, "提醒")
 If yesorno = vbOK Then
 tableobj.Delete
 xx.but_first.Value = True
 MsgBox "已经将数据删除完毕!", vbOKOnly, "提醒"
 End If
Else
 MsgBox "暂时不能将屏幕上数据删除！", vbOKCancel + vbCritical, "提醒"
 End If
 
End Sub
Private Sub shanchufrm(xx As Object, tableobj As Object)

 Dim yesorno As Integer
 If tableobj.Supports(adDelete) Then
 yesorno = MsgBox("是否将屏幕上数据删除?", vbOKCancel + vbCritical, "提醒")
 If yesorno = vbOK Then
 tableobj.Delete
' MsgBox "已经将数据删除完毕!", vbOKOnly, "提醒"
 End If
Else
 MsgBox "暂时不能将屏幕上数据删除！", vbOKCancel + vbCritical, "提醒"
 End If
 
End Sub
Private Function opentable(ByVal xx As Object, ByVal yy As String)
 
 If table.State = adStateClosed Then
 table.Open "detail", Connection, adOpenKeyset, adLockOptimistic
 End If
 If Not (table.BOF And table.EOF) Then
 table.MoveFirst
 showfields xx, table
 End If
 xx.but_dakai.enabled = False
 xx.but_zenjia.enabled = True
 xx.but_xiugai.enabled = True
 xx.but_shanchu.enabled = True
 movex xx, True
 disablefields (xx)
 
End Function
Public Function getrecordindex(ByVal str As String) As Integer
  
 
 Dim xxx, inde, i, fid As Integer
   fid = -999
   For i = 0 To table.fields.Count - 1
   If "商品条码" = table.fields(i).Name Then
     inde = i
    End If
   Next
Dim hasresult As Boolean

 table.MoveFirst
 For i = 0 To table.RecordCount - 1
    If CStr(table.fields(inde).Value) = str Then
     hasresult = True
     getrecordindex = i
     Exit Function
     Else
     hasresult = False
    End If
table.MoveNext
Next
If Not hasresult Then
getrecordindex = -999
End If

End Function

Private Function move2index(ByVal indexnum As Integer) As Boolean

 If table.Move(indexnum, 1) Then
   move2index = True
   Else
 move2index = False
End If

End Function
Private Function listalltable(ByVal systablename As String, ByVal xx As Object)

If table.State = adStateOpen Then
 table.Close
End If
table.Open systablename, Connection
table.MoveFirst
Do While Not table.EOF
If table.fields("TableName") <> "MSysTables" And _
table.fields("TableName") <> "MSysFields" And _
table.fields("TableName") <> "MSysIndexes" And _
table.fields("TableName") <> "MSysProcs" Then
stablename = table.fields("TableName")
tableid = CLng(table.fields("TableID")) '对于系统只有一张表来说，这个tableid是不变的
xx.tableidlist.AddItem table.fields("TableID")
xx.tablelist.AddItem table.fields("TableName")

End If
table.MoveNext
Loop
table.Close
xx.tablelist.ListIndex = 0
 If table.State = adStateClosed Then
table.Open "detail", Connection, adOpenKeyset, adLockOptimistic
End If

End Function
Private Function listallfields(ByVal sysfieldname As String, ByVal xx As Object)

totalfields = 0
If table.State = adStateOpen Then
 table.Close
End If
table.Open sysfieldname, Connection
table.MoveFirst
Do While Not table.EOF
If table.fields("TableID") = tableid Then
totalfields = totalfields + 1
End If
table.MoveNext
Loop
table.Close
If table.State = adStateClosed Then
table.Open "detail", Connection, adOpenKeyset, adLockOptimistic
End If

End Function
Private Function fieldtotalcount(ByVal sysfieldname As String, ByVal xx As Object)

Dim i As Integer
i = 0
listalltable "MSystables", frmMain
If table.State = adStateOpen Then
 table.Close
End If
table.Open "MSysfields", Connection
table.MoveFirst
Do While Not table.EOF
If table.fields("TableID") = tableid Then
 fieldnamearray(i) = table.fields("FieldName")
 i = i + 1
End If
table.MoveNext
Loop
table.Close
If table.State = adStateClosed Then
table.Open "detail", Connection, adOpenKeyset, adLockOptimistic
End If

End Function

Private Function showallfields(ByVal xx As Object)

Erase fieldnamearray
 Dim i As Integer
 If table.BOF And table.EOF Then
 MsgBox table & " 没有任何记录", vbOKOnly, "注意"
 End If

Dim s As Integer
s = xx.datagrid.Rows
 For i = 1 To s
xx.datagrid.RemoveItem 0
Next

Dim title As String
Dim data As String
xx.datagrid.Cols = 3
xx.datagrid.ColWidth(0) = Len("Name") * 200
xx.datagrid.ColWidth(1) = Len("Type") * 160
xx.datagrid.ColWidth(2) = Len("字段大小") * 200
xx.datagrid.AddItem "名称" & vbTab & "类型" & vbTab & "字段大小"

xx.datagrid.Cols = table.fields.Count
Dim xxx As Integer

xxx = xx.datagrid.Cols - 1
For i = 0 To xxx
   title = table.fields(i).Name & vbTab & table.fields(i).Type & vbTab & table.fields(i).DefinedSize
   xx.datagrid.AddItem title
   fieldnamearray(i) = table.fields(i).Name
 Next
xx.datagrid.Redraw = True

End Function

Private Function showallfieldshasarray(ByVal xx As Object)

 Erase fieldnamearray
 Dim i As Integer
 If table.BOF And table.EOF Then
 MsgBox table & " 没有任何记录", vbOKOnly, "注意"
 End If
Dim s As Integer
s = xx.datagrid.Rows
 For i = 1 To s
xx.datagrid.RemoveItem 0
Next
Dim title As String
Dim data As String
xx.datagrid.Cols = 3
xx.datagrid.ColWidth(0) = Len("Name") * 350
xx.datagrid.ColWidth(1) = Len("Type") * 200
xx.datagrid.ColWidth(2) = Len("字段大小") * 200
xx.datagrid.AddItem "字段名称" & vbTab & "类型" & vbTab & "字段大小"
xx.datagrid.Cols = table.fields.Count
Dim xxx As Integer
xxx = xx.datagrid.Cols - 1
For i = 0 To xxx
   title = table.fields(i).Name & vbTab & table.fields(i).Type & vbTab & table.fields(i).DefinedSize
   xx.datagrid.AddItem title
   fieldnamearray(i) = table.fields(i).Name
 Next
xx.datagrid.Redraw = True

End Function
Private Function showallfieldshasarray_combo(ByVal xx As Object)

 Erase fieldnamearray
 Dim i As Integer
 If table.BOF And table.EOF Then
 MsgBox table & " 没有任何记录", vbOKOnly, "注意"
 End If
 Dim title As String

xx.datagrid.Cols = table.fields.Count
Dim xxx As Integer
xxx = xx.datagrid.Cols - 1
For i = 0 To xxx
   'title = table.fields(i).Name & vbTab & table.fields(i).Type & vbTab & table.fields(i).DefinedSize
   xx.fieldcom.AddItem table.fields(i).Name
   fieldnamearray(i) = table.fields(i).Name
 Next
xx.datagrid.Redraw = True

End Function
Public Sub indexbytablename(ByVal tbname As String, ByVal xx As Object)

 ' Dim tablename As String
 Dim i As Integer
If Not table.State = adStateClosed Then
    table.Close
End If
 table.Open tbname, Connection
 If table.BOF And table.EOF Then
MsgBox tbname & "中没有任何记录", vbOKOnly, "注意"
End If

Dim s As Integer
s = xx.datagrid.Rows
 For i = 1 To s
xx.datagrid.RemoveItem 0
Next

Dim title, m As String
Dim data As String
m = table.RecordCount
xx.datagrid.Cols = table.fields.Count
Dim xxx As Integer
xxx = xx.datagrid.Cols - 1
For i = 0 To xxx
  If i = xxx Then
  title = title & table.fields(i).Name

  Else
  title = title & table.fields(i).Name & vbTab

  End If
Next
xx.datagrid.AddItem title

table.MoveFirst

Dim j As Integer
 For i = 1 To table.RecordCount
    For j = 0 To xxx
       If j = xxx Then
           data = data & ridflux(table.fields(j).Value)
           xx.datagrid.ColWidth(j) = Len(table.fields(j).Name) + 1400
         Else
           data = data & ridflux(table.fields(j)) & vbTab
           xx.datagrid.ColWidth(j) = Len(table.fields(j).Name) + 1400
        End If
    Next
   xx.datagrid.AddItem data
     '  File1.LinePrint data
   data = ""
 table.MoveNext
 Next
 'File1.Close
 
 xx.datagrid.Redraw = True

End Sub
 
Public Function ridflux(ByVal dt As String) As String
  
  Dim pos As Integer
  pos = InStr(dt, ".")
  If pos > 0 Then
  ridflux = Mid(Trim(dt), 1, pos + 3)
  Else
  ridflux = dt
  End If
  

End Function
 Private Function ridnull(ByVal str As Variant) As String

Dim ss As String
If IsNull(str) Then
  ridnull = ""
  Else
  ridnull = str
End If
 
End Function