module1.bas

这是一个医院管理系统中的院长查询模块

Attribute VB_Name = "Module1"

'******************
Public yscxID As String
Public Cxzyh As String
Public TMYesNo As Boolean
Public PC_NO As Integer
Public PC_LX As Integer
Public CZYID
Public HYID
Public H_NO As String
Public GROUP As String
Public DxPass As String
Public DxPassWord As String
Public db As Database
Public menu
Public yj_code As String '药局分类
Public DS As String
Public mTime As Date

Public CzyQx As String
Public MmIN As Boolean
Public zzz As Integer
Public DS1 As String
Public Inagain_zyId As String
Public MyDatabase As String
Public MyConnect As String

Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByVal lpvParam As Any, ByVal fuWinIni As Long) As Long
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Const swp_hidewindow = &H80
Const swp_showwindow = &H40
Const spissr = 97
Dim hwnd1 As Long
Function DxLL(AAA) As String
If IsNull(AAA) Then
DxLL = ""
Else
If AAA = " " Then
DxLL = ""
Else
DxLL = CStr(AAA)
End If
End If
End Function

Sub hidewindows()
Dim ret As Integer
Dim pold As Long
ret = SystemParametersInfo(spissr, True, pold, 0)
hwnd1 = FindWindow("shell_traywnd", "")
Call SetWindowPos(hwnd1, 0, 0, 0, 0, 0, swp_hidewindow)
End Sub
Sub showwindows()
Dim ret As Integer
Dim pold As Long
ret = SystemParametersInfo(spissr, False, pold, 0)
Call SetWindowPos(hwnd1, 0, 0, 0, 0, 0, swp_showwindow)
End Sub

Sub Main()
MyDatabase = "207his"
MyConnect = "odbc;uid=zwj;pwd=qqq;database=netba"

If App.PrevInstance Then
    End
End If

If Len(CStr(Date)) < 9 Then
    MsgBox "警告：日期错误，请将日期格式改成长日期格式！"
    End
End If
ss = Val((3.46 / 2) * 2 + 5 - 5)
If ss <> 3.46 Then
    MsgBox "警告：区域设置中数字设置错误，请更改区域设置！"
    End
End If

Set db = OpenDatabase(MyDatabase, False, False, MyConnect)
'''''''''''''''''''药品系统
    dbfstr = "ODBC;DATABASE=netba;UID=sa;PWD=have"
    Set wrkODBC = CreateWorkspace("ODBCWorkspace", "admin", "", dbUseODBC)
    Workspaces.Append wrkODBC
    Set wrkJet = CreateWorkspace("JetWorkspace", "admin", "", dbUseJet)
    Workspaces.Append wrkJet
    DBEngine.DefaultType = dbUseJet
''''''''''''''''''''''''''''

Form11.Show
End Sub
Function DxNULL(AAA As String) As String
If IsNull(AAA) Then
DxNULL = " "
Else
If AAA = "" Then
DxNULL = " "
Else
DxNULL = AAA
End If
End If
End Function
'本函数完成现金数据的大写金额转换
Function DxCcur(MONEY As String)
Dim DXJE(0 To 9) As String
DXJE(0) = " 零"
DXJE(1) = " 壹"
DXJE(2) = " 贰"
DXJE(3) = " 叁"
DXJE(4) = " 肆"
DXJE(5) = " 伍"
DXJE(6) = " 陆"
DXJE(7) = " 柒"
DXJE(8) = " 捌"
DXJE(9) = " 玖"
XX1 = InStr(MONEY, ".")
If XX1 = 0 Then
S_MONEY = ".00"
T_MONEY = MONEY
Else
T_MONEY = Left$(MONEY, XX1 - 1)
S_MONEY = Mid$(MONEY, XX1)
End If
L1 = Len(T_MONEY)
L2 = Len(S_MONEY)
If L2 < 3 Then
S_MONEY = S_MONEY + "0"
End If
MONEYS = ""
Select Case L1
Case 8
MONEYS = DXJE(Val(Mid$(T_MONEY, 1, 1))) + "仟"
MONEYS = MONEYS + DXJE(Val(Mid$(T_MONEY, 2, 1))) + "佰"
MONEYS = MONEYS + DXJE(Val(Mid$(T_MONEY, 3, 1))) + "拾"
MONEYS = MONEYS + DXJE(Val(Mid$(T_MONEY, 4, 1))) + "万"
MONEYS = MONEYS + DXJE(Val(Mid$(T_MONEY, 5, 1))) + "仟"
MONEYS = MONEYS + DXJE(Val(Mid$(T_MONEY, 6, 1))) + "佰"
MONEYS = MONEYS + DXJE(Val(Mid$(T_MONEY, 7, 1))) + "拾"
MONEYS = MONEYS + DXJE(Val(Mid$(T_MONEY, 8, 1))) + "元"
Case 7
MONEYS = DXJE(Val(Mid$(T_MONEY, 1, 1))) + "佰"
MONEYS = MONEYS + DXJE(Val(Mid$(T_MONEY, 2, 1))) + "拾"
MONEYS = MONEYS + DXJE(Val(Mid$(T_MONEY, 3, 1))) + "万"
MONEYS = MONEYS + DXJE(Val(Mid$(T_MONEY, 4, 1))) + "仟"
MONEYS = MONEYS + DXJE(Val(Mid$(T_MONEY, 5, 1))) + "佰"
MONEYS = MONEYS + DXJE(Val(Mid$(T_MONEY, 6, 1))) + "拾"
MONEYS = MONEYS + DXJE(Val(Mid$(T_MONEY, 7, 1))) + "元"
Case 6
MONEYS = DXJE(Val(Mid$(T_MONEY, 1, 1))) + "拾"
MONEYS = MONEYS + DXJE(Val(Mid$(T_MONEY, 2, 1))) + "万"
MONEYS = MONEYS + DXJE(Val(Mid$(T_MONEY, 3, 1))) + "仟"
MONEYS = MONEYS + DXJE(Val(Mid$(T_MONEY, 4, 1))) + "佰"
MONEYS = MONEYS + DXJE(Val(Mid$(T_MONEY, 5, 1))) + "拾"
MONEYS = MONEYS + DXJE(Val(Mid$(T_MONEY, 6, 1))) + "元"
Case 5
MONEYS = DXJE(Val(Mid$(T_MONEY, 1, 1))) + "万"
MONEYS = MONEYS + DXJE(Val(Mid$(T_MONEY, 2, 1))) + "仟"
MONEYS = MONEYS + DXJE(Val(Mid$(T_MONEY, 3, 1))) + "佰"
MONEYS = MONEYS + DXJE(Val(Mid$(T_MONEY, 4, 1))) + "拾"
MONEYS = MONEYS + DXJE(Val(Mid$(T_MONEY, 5, 1))) + "元"
Case 4
MONEYS = DXJE(Val(Mid$(T_MONEY, 1, 1))) + "仟"
MONEYS = MONEYS + DXJE(Val(Mid$(T_MONEY, 2, 1))) + "佰"
MONEYS = MONEYS + DXJE(Val(Mid$(T_MONEY, 3, 1))) + "拾"
MONEYS = MONEYS + DXJE(Val(Mid$(T_MONEY, 4, 1))) + "元"
Case 3
MONEYS = DXJE(Val(Mid$(T_MONEY, 1, 1))) + "佰"
MONEYS = MONEYS + DXJE(Val(Mid$(T_MONEY, 2, 1))) + "拾"
MONEYS = MONEYS + DXJE(Val(Mid$(T_MONEY, 3, 1))) + "元"
Case 2
MONEYS = DXJE(Val(Mid$(T_MONEY, 1, 1))) + "拾"
MONEYS = MONEYS + DXJE(Val(Mid$(T_MONEY, 2, 1))) + "元"
Case 1
MONEYS = DXJE(Val(Mid$(T_MONEY, 1, 1))) + "元"
Case Else
MONEYS = ""
End Select
MONEYS = MONEYS + DXJE(Val(Mid$(S_MONEY, 2, 1))) + "角" + DXJE(Val(Mid$(S_MONEY, 3, 1))) + "分"
DxCcur = MONEYS
End Function
Function DxLen(XX As String)
Dim ss As Integer
ss = 0
For i = 1 To Len(XX)
A1 = Asc(Mid$(XX, i, 1))
If A1 > 0 Then
ss = ss + 1
Else
ss = ss + 2
End If
Next i
DxLen = ss
End Function
Function DxF(XX As Variant)
If IsNull(XX) Then
DxF = ""
GoTo EX
End If
If Val(XX) = 0 Then
DxF = ""
Else
DxF = CStr(Format(Val(XX), "0.00"))
End If
EX:
End Function
Function DxFX(XX As Variant)
If IsNull(XX) Then
DxFX = ""
GoTo EX
End If
If Val(XX) = 0 Then
DxFX = ""
Else
DxFX = CStr(Format(-Val(XX), "0.00"))
End If
EX:
End Function
Function DxFF(XX As Variant)
If IsNull(XX) Then
DxFF = ""
GoTo EX
End If
If Val(XX) = 0 Then
DxFF = ""
Else
DxFF = CStr(Format(Val(XX), "0.0000"))
End If
EX:
End Function
Function DxCStr(XX As Variant)
If IsNull(XX) Then
DxCStr = ""
GoTo EX
End If
If Val(XX) = 0 Then
DxCStr = ""
Else
DxCStr = CStr(XX)
End If
EX:
End Function
Function DxCInt(XX As String)
DxCInt = CStr(CLng(Val(XX) * 100) / 100)
End Function
Function DxLeft(XX As String, Y As Integer)
If DxLen(XX) <= Y Then
DxLeft = XX
Else
If DxLen(XX) <> Len(XX) Then
DxLeft = Left$(XX, CInt(Y / 2))
Else
DxLeft = Left$(XX, Y)
End If
End If
End Function
Function DxMmm(X As String)
K = Len(X)
D = ""
For i = 1 To K
L = Mid$(X, i, 1)
L = Chr$(Asc(L) - 1128)
D = D + L
Next i
DxMmm = D
End Function

Function DxDATE(XX As Variant)
If IsDate(XX) Then
DxDATE = CDate(XX)
Else
DxDATE = Null
End If
End Function
Function DxDATES(XX As Variant)
If IsNull(XX) Then
DxDATES = "    -  -  "
Else
DxDATES = CDate(XX)
End If
End Function



Public Function ISNum(S1 As String) As Boolean
  Dim i As Integer
  Dim j As Integer
  Dim s As String
  j = 0
  If S1 = "" Then
   ISNum = False
   GoTo E
  End If
   
  For i = 1 To Len(S1)
   s = Mid(S1, i, 1)
   If Asc(s) >= 48 And Asc(s) <= 57 Then
      ISNum = True
   ElseIf Asc(s) = 46 Then
      j = j + 1
   Else
      ISNum = False
      Exit Function
   End If
  Next i
  If j > 1 Then
   ISNum = False
  End If
E:
End Function
Public Function ISChr(s As String) As Boolean
  If Asc(s) > 65 Then
   ISChr = True
  Else
   ISChr = False
  End If
End Function

Public Function GetHz(DM As String) As String '取汇总标志
  Dim rs As Recordset
  Dim dd As String
  dd = Left(DM, 2) & "00"
  Set rs = db.OpenRecordset("SELECT * FROM ZY_FYHZ WHERE XM_DM='" + Trim(dd) + "'")
  If Not rs.EOF Then
   GetHz = rs!HZ_BZ
  Else
   GetHz = "11"
  End If
  rs.Close
End Function
Public Function GetDate() As Date
 'If Time > TIMES Then
  'GetDate = Date + 1
 'Else
  GetDate = Date
 'End If
End Function