modglasses.bas

一个实用的房产信息管理系统

Attribute VB_Name = "modGlasses"
Option Explicit
Public dbEstate As Database
Public sBuffer As String
Public GongH As String
Public dbstu As Database
Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long

Public Sub Main()
Set dbEstate = OpenDatabase(App.Path & "\dbestate.mdb", False, False)

Dim DirLenth As Integer
sBuffer = Space(255)
DirLenth = GetWindowsDirectory(sBuffer, 255)
sBuffer = Left(sBuffer, DirLenth)
If Right(RTrim(sBuffer), 1) <> "\" Then
    sBuffer = RTrim(sBuffer) & "\"
Else
    sBuffer = RTrim(sBuffer)
End If

Frmflash.Show vbModal
End Sub


Public Sub PrintInExcel(ByVal recPrint As Recordset, ByVal FileName As String, ByVal Char As String)
Dim dbExcel As Database
Dim recExcel As Recordset
Set dbExcel = OpenDatabase(App.Path + "\" + FileName, False, False, "Excel 8.0;HDR=NO;")
Dim FieldCount As Integer
FieldCount = recPrint.RecordCount
Set recExcel = dbExcel.OpenRecordset("A3:" & Char & "3")
recExcel.MoveLast
If recPrint.AbsolutePosition = -1 Then
MsgBox "无任何记录可供打印！", vbExclamation + vbOKOnly, "错误提示"
Exit Sub
End If

recPrint.MoveFirst
Dim I As Integer
While Not recPrint.EOF
  recExcel.AddNew
  For I = 0 To recPrint.Fields.Count - 1
    recExcel.Fields(I).Value = recPrint.Fields(I).Value
  Next I
  recExcel.Update
  recPrint.MoveNext
Wend
End Sub

Public Function ZhiCOut(ByVal x As Integer) As String
Dim recZhic As Recordset
Set recZhic = dbEstate.OpenRecordset("select mc from zhic where id=" + CStr(x) + "", dbOpenSnapshot)
If recZhic.RecordCount > 0 Then
    ZhiCOut = recZhic!mc
Else
    ZhiCOut = ""
End If
End Function

Public Function ZhiCIn(ByVal x As String) As String
Dim recZhic As Recordset
Set recZhic = dbEstate.OpenRecordset("select id from zhic where mc='" + CStr(x) + "'", dbOpenSnapshot)
If recZhic.RecordCount > 0 Then
    ZhiCIn = CStr(recZhic!ID)
Else
    ZhiCIn = ""
End If
End Function


Public Function ZhiWOut(ByVal x As Integer) As String
Dim recZhicw As Recordset
Set recZhicw = dbEstate.OpenRecordset("select mc from zhiw where id=" + CStr(x) + "", dbOpenSnapshot)
If recZhicw.RecordCount > 0 Then
    ZhiWOut = recZhicw!mc
Else
    ZhiWOut = ""
End If
End Function

Public Function ZhiWIn(ByVal x As String) As String
Dim recZhiwc As Recordset
Set recZhiwc = dbEstate.OpenRecordset("select id from zhiw where mc='" + CStr(x) + "'", dbOpenSnapshot)
If recZhiwc.RecordCount > 0 Then
    ZhiWIn = CStr(recZhiwc!ID)
Else
    ZhiWIn = ""
End If
End Function


Public Function HunYOut(ByVal x As Integer) As String
Select Case x
Case 1
  HunYOut = "未婚"
Case 2
  HunYOut = "已婚"
Case 3
  HunYOut = "离婚"
Case 4
  HunYOut = "再婚"
Case 5
  HunYOut = "丧偶"
Case Else
  HunYOut = ""
End Select
End Function

Public Function HunYIn(ByVal x As String) As String
Select Case x
Case "未婚"
  HunYIn = "1"
Case "已婚"
  HunYIn = "2"
Case "离婚"
  HunYIn = "3"
Case "再婚"
  HunYIn = "4"
Case "丧偶"
  HunYIn = "5"
Case ""
  HunYIn = ""
End Select
End Function

Public Function RenYZKOut(ByVal x As Integer) As String
Select Case x
Case 1
  RenYZKOut = "在编"
Case 2
  RenYZKOut = "出国"
Case 3
  RenYZKOut = "离休"
Case 4
  RenYZKOut = "退休"
Case 5
  RenYZKOut = "去世"
Case 6
  RenYZKOut = "调外"
Case 7
  RenYZKOut = "其它"
Case 8
  RenYZKOut = "辞职"
Case Else
  RenYZKOut = ""
End Select
End Function

Public Function RenYZKIn(ByVal x As String) As String
Select Case x
Case "在编"
  RenYZKIn = "1"
Case "出国"
  RenYZKIn = "2"
Case "离休"
  RenYZKIn = "3"
Case "退休"
  RenYZKIn = "4"
Case "去世"
  RenYZKIn = "5"
Case "调外"
  RenYZKIn = "6"
Case "其它"
  RenYZKIn = "7"
Case "辞职"
  RenYZKIn = "8"
Case Else
  RenYZKIn = ""
End Select
End Function