frmdata.frm

一个水情自动测报系统的接收例程

If Me.grdDataGrid.AllowAddNew Then
  adoPrimaryRS.MoveLast
  adoPrimaryRS.AddNew
  grdDataGrid.SetFocus
End If
  Exit Sub
AddErr:
  MsgBox Err.Description
End Sub

Private Sub cmdDelete_Click()
  On Error GoTo DeleteErr
If Me.grdDataGrid.AllowDelete Then
  With adoPrimaryRS
    .Delete
    .MoveNext
    If .EOF Then .MoveLast
  End With
End If
  Exit Sub
DeleteErr:
  MsgBox Err.Description
End Sub

Public Sub cmdRefresh_Click()
  '只有多用户应用程序需要
  On Error GoTo RefreshErr
  Set grdDataGrid.DataSource = Nothing
  adoPrimaryRS.Requery
  Set grdDataGrid.DataSource = adoPrimaryRS

  Exit Sub
RefreshErr:
  MsgBox Err.Description
End Sub

Private Sub cmdEdit_Click()
  On Error GoTo EditErr

  lblStatus.Caption = "编辑记录"
  mbEditFlag = True
  SetButtons False
  Exit Sub

EditErr:
  MsgBox Err.Description
End Sub
Private Sub cmdCancel_Click()
  On Error Resume Next

  SetButtons True
  mbEditFlag = False
  mbAddNewFlag = False
  adoPrimaryRS.CancelUpdate
  If mvBookMark > 0 Then
    adoPrimaryRS.Bookmark = mvBookMark
  Else
    adoPrimaryRS.MoveFirst
  End If
  mbDataChanged = False

End Sub

Private Sub cmdUpdate_Click()
  On Error GoTo UpdateErr


If Me.grdDataGrid.AllowUpdate Then
  adoPrimaryRS.UpdateBatch adAffectAll

  If mbAddNewFlag Then
    adoPrimaryRS.MoveLast              '移到新记录
  End If

  mbEditFlag = False
  mbAddNewFlag = False
  SetButtons True
  mbDataChanged = False
End If

  Exit Sub
UpdateErr:
  MsgBox Err.Description
End Sub

Private Sub cmdClose_Click()
On Error Resume Next

  Unload Me
End Sub

Private Sub cmdFirst_Click()
  On Error GoTo GoFirstError

  adoPrimaryRS.MoveFirst
  mbDataChanged = False

  Exit Sub

GoFirstError:
  MsgBox Err.Description
End Sub

Private Sub cmdLast_Click()
  On Error GoTo GoLastError

  adoPrimaryRS.MoveLast
  mbDataChanged = False

  Exit Sub

GoLastError:
  MsgBox Err.Description
End Sub

Private Sub cmdNext_Click()
  On Error GoTo GoNextError

  If Not adoPrimaryRS.EOF Then adoPrimaryRS.MoveNext
  If adoPrimaryRS.EOF And adoPrimaryRS.RecordCount > 0 Then
    Beep
     '已到最后返回
    adoPrimaryRS.MoveLast
  End If
  '显示当前记录
  mbDataChanged = False

  Exit Sub
GoNextError:
  MsgBox Err.Description
End Sub

Private Sub cmdPrevious_Click()
  On Error GoTo GoPrevError

  If Not adoPrimaryRS.BOF Then adoPrimaryRS.MovePrevious
  If adoPrimaryRS.BOF And adoPrimaryRS.RecordCount > 0 Then
    Beep
    '已到最后返回
    adoPrimaryRS.MoveFirst
  End If
  '显示当前记录
  mbDataChanged = False

  Exit Sub

GoPrevError:
  MsgBox Err.Description
End Sub

Private Sub SetButtons(bVal As Boolean)
On Error Resume Next

  cmdAdd.Visible = bVal
  cmdEdit.Visible = bVal
  cmdUpdate.Visible = Not bVal
  cmdCancel.Visible = Not bVal
  cmdDelete.Visible = bVal
  cmdClose.Visible = bVal
  cmdRefresh.Visible = bVal
  cmdNext.Enabled = bVal
  cmdFirst.Enabled = bVal
  cmdLast.Enabled = bVal
  cmdPrevious.Enabled = bVal
End Sub

Public Sub Printer_Tables()
Dim i, j, k, P As Integer
Dim lon As Long
Dim Fil As Field
Dim XX, YY As Integer

On Error Resume Next


XX = 0
YY = 0
Printer.ScaleMode = 3
Printer.DrawWidth = 5



lon = adoPrimaryRS.RecordCount
If lon <> 0 Then
adoPrimaryRS.MoveFirst
End If


k = 0: P = 1 'K=HANG,P=YE
If Not adoPrimaryRS.BOF Then '1
Do While (Not adoPrimaryRS.EOF) '2

If k = 0 Then
        Printer.CurrentX = XX + 0
        Printer.CurrentY = YY + 0
        Printer.Print Me.Caption

i = 0: j = 0
For Each Fil In adoPrimaryRS.Fields
           Printer.Line (XX + i * 900, YY + 200 - 70)- _
                        (XX + i * 900, YY + 200 + 130) '纵线
        Printer.CurrentX = XX + i * 900 + 250
        Printer.CurrentY = YY + 200
        Printer.Print Fil.Name
        i = i + 1
        j = j + 1
Next
   Printer.Line (XX, YY + 130)- _
      (XX + i * 900, YY + 130) '横线
      
   Printer.Line (XX, YY + 200 + 130)- _
      (XX + i * 900, YY + 200 + 130) '横线
   Printer.Line (XX + i * 900, YY + 200 - 70)- _
                (XX + i * 900, YY + 200 + 130) '纵线
End If

For i = 0 To j - 1
        Printer.Line (XX + i * 900, YY + 200 * k + 200 + 130)- _
                     (XX + i * 900, YY + 200 * k + 200 + 200 + 130) '纵线
        Printer.CurrentX = XX + i * 900
        Printer.CurrentY = YY + 200 * k + 400
        If Not (IsNull(adoPrimaryRS.Fields(i).Value)) Then
        Printer.Print adoPrimaryRS.Fields(i).Value
        End If
Next i

   Printer.Line (XX, YY + 200 * k + 400 + 130)- _
      (XX + i * 900, YY + 200 * k + 400 + 130) '横线
Printer.Line (XX + i * 900, YY + 200 * k + 400 - 70)- _
             (XX + i * 900, YY + 200 * k + 400 + 130) '纵线


k = k + 1
If k = hangshu Then '3


        Printer.CurrentX = XX
        Printer.CurrentY = YY + 200 * k + 400
        Printer.Print "第" & CStr(P) & "页共" & CStr((lon + hangshu - 1) \ hangshu) & "页"

        Printer.CurrentX = XX + 800
        Printer.CurrentY = YY + 200 * k + 400
        Printer.Print Format$(Now(), "yyyy-mm-dd hh:mm:ss")
        
Printer.EndDoc
k = 0
P = P + 1
End If '3
adoPrimaryRS.MoveNext
Loop '2



If k <> 0 Then '9
        Printer.CurrentX = XX
        Printer.CurrentY = YY + 200 * k + 400
        Printer.Print "第" & CStr(P) & "页共" & CStr((lon + hangshu) \ hangshu) & "页"

        Printer.CurrentX = XX + 800
        Printer.CurrentY = YY + 200 * k + 400
        Printer.Print Format$(Now(), "yyyy-mm-dd hh:mm:ss")
Printer.EndDoc
End If '9

Else '1
        Printer.CurrentX = XX + 0
        Printer.CurrentY = YY + 0
        Printer.Print Me.Caption

i = 0: j = 0
For Each Fil In adoPrimaryRS.Fields
           Printer.Line (XX + i * 900, YY + 200 - 70)- _
                        (XX + i * 900, YY + 200 + 130) '纵线
        Printer.CurrentX = XX + i * 900 + 250
        Printer.CurrentY = YY + 200
        Printer.Print Fil.Name
        i = i + 1
        j = j + 1
Next
   Printer.Line (XX, YY + 130)- _
      (XX + i * 900, YY + 130) '横线
      
   Printer.Line (XX, YY + 200 + 130)- _
      (XX + i * 900, YY + 200 + 130) '横线
   Printer.Line (XX + i * 900, YY + 200 - 70)- _
                (XX + i * 900, YY + 200 + 130) '纵线
                
        Printer.CurrentX = XX
        Printer.CurrentY = YY + 400
        Printer.Print "第1页共页" & CStr((lon + hangshu) \ hangshu) & "页"

        Printer.CurrentX = XX + 800
        Printer.CurrentY = YY + 400
        Printer.Print Format$(Now(), "yyyy-mm-dd hh:mm:ss")
Printer.EndDoc
End If '1


End Sub

Private Sub PRIN_Click()
On Error Resume Next
Set adoPrimaryRS = grdDataGrid.DataSource
Call Printer_Tables
End Sub

Private Sub SADASD_Click()
On Error Resume Next
Call cmdRefresh_Click
End Sub

Private Sub SDSAD_Click()
    On Error GoTo SortErr

    Dim recRecordset1 As Recordset
    Dim SortStr As String


    Set recRecordset1 = grdDataGrid.DataSource                    '复制记录集
    
    If Len(msSortCol) = 0 Then
        SortStr = InputBox("输入排序的列：", , "时间")
        If Len(SortStr) = 0 Then Exit Sub
    Else
        SortStr = msSortCol
    End If

    Screen.MousePointer = vbHourglass
    recRecordset1.Sort = SortStr
    
    '建立排序
    Set grdDataGrid.DataSource = recRecordset1
    
    Screen.MousePointer = vbDefault
    Exit Sub

SortErr:
    Screen.MousePointer = vbDefault
    MsgBox "错误：" & Err & "，" & Err.Description

End Sub

Private Sub sdsdad_Click()
On Error GoTo ErrHandler
CommonDialog1.CancelError = True
CommonDialog1.Flags = cdlCFEffects Or cdlCFBoth
CommonDialog1.ShowFont

With Me.grdDataGrid
.Font.Name = CommonDialog1.FileName
.Font.Size = CommonDialog1.FontSize
.Font.Bold = CommonDialog1.FontBold
.Font.Italic = CommonDialog1.FontItalic
.Font.Underline = CommonDialog1.FontUnderline
.ForeColor = CommonDialog1.Color
End With

    SaveSetting appname:=App.title, section:="FONT", _
            Key:="Name", setting:=grdDataGrid.Font.Name
            
    SaveSetting appname:=App.title, section:="FONT", _
            Key:="Size", setting:=grdDataGrid.Font.Size
            
    SaveSetting appname:=App.title, section:="FONT", _
            Key:="Bold", setting:=grdDataGrid.Font.Bold
            
    SaveSetting appname:=App.title, section:="FONT", _
            Key:="Italic", setting:=grdDataGrid.Font.Italic
            
    SaveSetting appname:=App.title, section:="FONT", _
            Key:="Underline", setting:=grdDataGrid.Font.Underline
            
    SaveSetting appname:=App.title, section:="FONT", _
            Key:="ForeColor", setting:=grdDataGrid.ForeColor


Exit Sub

ErrHandler:
 '用户按了“取消”按钮
Exit Sub
End Sub

Private Sub sfdsfsdf_Click()
On Error GoTo ErrHandler
CommonDialog1.CancelError = True
CommonDialog1.Flags = cdlCFEffects Or cdlCFBoth
CommonDialog1.ShowFont

With Me.grdDataGrid
.HeadFont.Name = CommonDialog1.FileName
.HeadFont.Size = CommonDialog1.FontSize
.HeadFont.Bold = CommonDialog1.FontBold
.HeadFont.Italic = CommonDialog1.FontItalic
.HeadFont.Underline = CommonDialog1.FontUnderline
End With

    SaveSetting appname:=App.title, section:="HeadFONT", _
            Key:="Name", setting:=grdDataGrid.HeadFont.Name
            
    SaveSetting appname:=App.title, section:="HeadFONT", _
            Key:="Size", setting:=grdDataGrid.HeadFont.Size
            
    SaveSetting appname:=App.title, section:="HeadFONT", _
            Key:="Bold", setting:=grdDataGrid.HeadFont.Bold
            
    SaveSetting appname:=App.title, section:="HeadFONT", _
            Key:="Italic", setting:=grdDataGrid.HeadFont.Italic
            
    SaveSetting appname:=App.title, section:="HeadFONT", _
            Key:="Underline", setting:=grdDataGrid.HeadFont.Underline
            
Exit Sub

ErrHandler:
 '用户按了“取消”按钮
Exit Sub
End Sub

Private Sub szfdzf_Click()
On Error GoTo ErrHandler
CommonDialog1.CancelError = True
CommonDialog1.Flags = cdlCCRGBInit
CommonDialog1.ShowColor


SaveSetting appname:=App.title, section:="BACKGROUND", _
            Key:="Color", setting:=CommonDialog1.Color


Me.grdDataGrid.BackColor = CommonDialog1.Color


Exit Sub

ErrHandler:
 '用户按了“取消”按钮
Exit Sub

End Sub


Private Sub WAEWR_Click()
    Dim recRecordset1 As Recordset
    Dim sFilterStr As String
    
    On Error GoTo FilterErr

    Set recRecordset1 = grdDataGrid.DataSource                 '复制记录集
   
    sFilterStr = InputBox("输入过滤器表达式：")
    If Len(sFilterStr) = 0 Then Exit Sub

    Screen.MousePointer = vbHourglass
    recRecordset1.Filter = sFilterStr
    Set grdDataGrid.DataSource = recRecordset1                         '赋值为初始记录集对象

    Screen.MousePointer = vbDefault
    Exit Sub

FilterErr:
    Screen.MousePointer = vbDefault
    MsgBox "错误：" & Err & "，" & Err.Description

End Sub