module1.bas

适合乡镇供电所使用电费处理系统v3 软件

Attribute VB_Name = "Modulel"
Public username, CompName         '计算机用户名
Public Operator As String           '操作员
Public pbDw As String    '用户单位
Public pbDwBm As String    '用户单位编码
Public pbUserName As String          '当前用户名称
Public pbUserPermission As String    '当前用户权限
Public XzName As String, XzCode As String, XcName As String, XcCode As String, GzNian As String, GzYue As String, UserSeek As String
Public NdMd As Database, MdbR As Recordset    '全局库名，表名
Public StruA$, StruB$, StruC$, StruD
Public Cela As Boolean
Public Dbk As String
Public BenY As String, NianVal As String, ShangY As String
Public FrmIndex As Integer
Public AAA As String, AA As String, BB As String, CC As String, DD As String, EE As String, FF As String, GG As String, HH As String, II As String, JJ As String, KK As String, BBB As String, CCC As String, LL As String, VV As String
Public TrimitName   As String

Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long
Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
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
Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long

Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Declare Function Rectangle Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long

Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Public Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long

'拷贝文件
Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long

Declare Function SelectObject Lib "user32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public 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

Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessID As Long) As Long

'Public Const BITSPIXEL = 12
'Public Const HORZRES = 8
'Public Const VERTRES = 10
'Public Const PLANES = 14
Global hdesktopwnd
Global hdccaps
Global GetVal As Long

Type RECT
     Left As Long
     Top As Long
     Right As Long
     Bottom As Long
End Type

'拷贝文件--------------------------------------------
Public Const FO_MOVE As Long = &H1
Public Const FO_COPY As Long = &H2
Public Const FO_DELETE As Long = &H3
Public Const FO_RENAME As Long = &H4
Public Const FOF_MULTIDESTFILES As Long = &H1
Public Const FOF_CONFIRMMOUSE As Long = &H2
Public Const FOF_SILENT As Long = &H4
Public Const FOF_RENAMEONCOLLISION As Long = &H8
Public Const FOF_NOCONFIRMATION As Long = &H10
Public Const FOF_WANTMAPPINGHANDLE As Long = &H20
Public Const FOF_CREATEPROGRESSDLG As Long = &H0
Public Const FOF_ALLOWUNDO As Long = &H40
Public Const FOF_FILESONLY As Long = &H80
Public Const FOF_SIMPLEPROGRESS As Long = &H100
Public Const FOF_NOCONFIRMMKDIR As Long = &H200

Type SHFILEOPSTRUCT
     hwnd As Long
     wFunc As Long
     pFrom As String
     pTo As String
     fFlags As Long
     fAnyOperationsAborted As Long
     hNameMappings As Long
     lpszProgressTitle As String
End Type
'----------------------------------------------------------


'窗口置前-----------------------------------
Public Const HWND_TOPMOST = -1
Public Const SWP_NOMOVE = &H2
Public Const SWP_NOSIZE = &H1
'-------------------------------------------

Public Const Xt = "系统管理员"
Public Const Pt = "普通管理员"
Public Const Kc = "可查看用户"

'Public Const SRCCOPY = &HCC0020

'///////////系统加载过程//////////////
Sub Main()
    frmSplash1.Show
    frmSplash1.Refresh
    frmMain.Show
  '  Load frmMain
    If App.PrevInstance Then
       MsgBox ("程序已经运行，不能再次装载！"), vbExclamation
       Unload frmMain
       End
    End If
    Dim fLogin As New frmLogin
    fLogin.Show vbModal
    Unload fLogin
    Unload frmSplash1
    Dim RegPassTrue As String
    RegPassTrue = GetSetting(App.EXEName, "RegInfo", "RegTrue", "")
    'If RegPassTrue = "" Then
    '   RegMsg.Show
    'End If
End Sub

'/////////滚动标题函数//////////
'Public Function ScrollText(strText As String) As String
'strText = (Right$(strText, Len(strText) - 1)) & Left$(strText, 1)
'ScrollText = strText
'End Function

'/////////提示信息/////////////
Sub Ms()
   MsgBox "请把鼠标移到左上角[单位选择]处，选择单位或村！", vbInformation + vbSystemModal, "提示"
End Sub
   
'////////动画窗口过程//////////
Sub ExplodeForm(f As Form, Movement As Integer)
    Dim myRect As RECT
    Dim formWidth%, formHeight%, i%, X%, Y%, cx%, cy%
    Dim TheScreen As Long
    Dim Brush As Long
    GetWindowRect f.hwnd, myRect
    formWidth = (myRect.Right - myRect.Left)
    formHeight = myRect.Bottom - myRect.Top
    TheScreen = GetDC(0)
    Brush = CreateSolidBrush(f.BackColor)
    For i = 1 To Movement
        cx = formWidth * (i / Movement)
        cy = formHeight * (i / Movement)
        X = myRect.Left + (formWidth - cx) / 2
        Y = myRect.Top + (formHeight - cy) / 2
        Rectangle TheScreen, X, Y, X + cx, Y + cy
    Next i
    X = ReleaseDC(0, TheScreen)
    DeleteObject (Brush)
End Sub
'装入资源文件中的图片
'Image1.Picture = LoadResPicture(107, vbResBitmap)

'//////////////动画关闭窗口过程//////////////
Public Sub ImplodeForm(f As Form, Direction As Integer, Movement As Integer, ModalState As Integer)
    Dim myRect As RECT
    Dim formWidth%, formHeight%, i%, X%, Y%, cx%, cy%
    Dim TheScreen As Long
    Dim Brush As Long
    
    GetWindowRect f.hwnd, myRect
    formWidth = (myRect.Right - myRect.Left)
    formHeight = myRect.Bottom - myRect.Top
    TheScreen = GetDC(0)
    Brush = CreateSolidBrush(f.BackColor)
    For i = Movement To 1 Step -1
        cx = formWidth * (i / Movement)
        cy = formHeight * (i / Movement)
        X = myRect.Left + (formWidth - cx) / 2
        Y = myRect.Top + (formHeight - cy) / 2
        Rectangle TheScreen, X, Y, X + cx, Y + cy
    Next i
    X = ReleaseDC(0, TheScreen)
    DeleteObject (Brush)
End Sub

'///////////////打开数据库///////////////
Sub OpenMdb()
   Set NdMd = DBEngine.Workspaces(0).OpenDatabase(App.Path & "\Data\Eletricity.Mdb")
End Sub

'///////////////置窗口于最上//////////
Public Function PutWindowOnTop(pFrm As Form)
  Dim lngWindowPosition As Long
  lngWindowPosition = SetWindowPos(pFrm.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)
End Function

'/////////////计算某月的天数//////////////
Public Function RDays(MYdate As Date) As Integer
    RDays = (31 - Day(DateSerial(Year(MYdate), Month(MYdate), 31)))
    If RDays = 0 Then
       RDays = 31
    Else
    End If
End Function

'/////////////////从指定路径中提取出文件名////////////
Function StripPath(T$) As String
Dim X%, ct%
StripPath$ = T$
X% = InStr(T$, "\")
Do While X%
ct% = X%
X% = InStr(ct% + 1, T$, "\")
Loop
If ct% > 0 Then StripPath$ = Mid$(T$, ct% + 1)
End Function

'///////////////析出文件所含路径//////////////////
Function ExtractPath(sFileName) As String
    Dim nIdx As Integer
    For nIdx = Len(sFileName) To 1 Step -1
       If Mid$(sFileName, nIdx, 1) = "\" Then
          ExtractPath = Mid$(sFileName, 1, nIdx)
          Exit Function
       End If
    Next nIdx
    ExtractPath = sFileName
End Function


'////////////字符串翻转////////////
Static Function reversestring(revstr As String) As String

    Dim doreverse As Long
    reversestring = ""
    For doreverse = Len(revstr) To 1 Step -1
        reversestring = reversestring & Mid$(revstr, doreverse, 1)
    Next
End Function


'/////////////计算一段时间的分钟数///////////

Public Function Minutes(d As Date) _
    As Long
    'Minutes since 1900
    Dim lPreviousDays As Long
    Dim lTotalMinutes As Long
    lPreviousDays = d - #1/1/1900#
    lTotalMinutes = _
        (lPreviousDays * 24) * 60
    lTotalMinutes = lTotalMinutes + _
        Hour(d) * 60
    lTotalMinutes = lTotalMinutes + _
        Minute(d)
    Minutes = lTotalMinutes