pubfunction.bas

自动回传考勤数据程序,小程序!大作用!可供大家参考一下!

Attribute VB_Name = "PubFunction"
Public ComNo As Integer
Public ComSpeed As Long
Public Const MaxMachineNo = 252
Public db As Connection
Public Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long


'''GetPrivateProfileString
'''
'''VB声明
'''Declare Function GetPrivateProfileString& Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String)
'''说明
'''为初始化文件中指定的条目取得字串
'''返回值
'''Long，复制到lpReturnedString缓冲区的字节数量，其中不包括那些NULL中止字符。如lpReturnedString缓冲区不够大，不能容下全部信息，就返回nSize-1（若lpApplicationName或lpKeyName为NULL，则返回nSize-2）
'''参数表
'''参数 类型及说明
'''lpApplicationName String，欲在其中查找条目的小节名称。这个字串不区分大小写。如设为vbNullString，就在lpReturnedString缓冲区内装载这个ini文件所有小节的列表
'''lpKeyName String，欲获取的项名或条目名。这个字串不区分大小写。如设为vbNullString，就在lpReturnedString缓冲区内装载指定小节所有项的列表
'''lpDefault String，指定的条目没有找到时返回的默认值。可设为空（""）
'''lpReturnedString String，指定一个字串缓冲区，长度至少为nSize
'''nSize Long，指定装载到lpReturnedString缓冲区的最大字符数量
'''lpFileName String，初始化文件的名字。如没有指定一个完整路径名，windows就在Windows目录中查找文件
'''注解
'''如lpKeyName参数为vbNullString，那么lpReturnedString缓冲区会载入指定小节所有设置项的一个列表。每个项都用一个NULL字符分隔，最后一个项用两个NULL字符中止。也请参考GetPrivateProfileInt函数的注解
'''
'''其他
'''在vb的api文本查看器中复制的声明为：Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long

Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long
'''WritePrivateProfileString
'''
'''VB声明
'''Declare Function WritePrivateProfileString& Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As String, ByVal lpFileName As String)
'''说明
'''在初始化文件指定小节内设置一个字串
'''返回值
'''Long，非零表示成功，零表示超时。会设置GetLastError
'''参数表
'''参数 类型及说明
'''lpApplicationName String，要在其中写入新字串的小节名称。这个字串不区分大小写
'''lpKeyName Any，要设置的项名或条目名。这个字串不区分大小写。用vbNullString可删除这个小节的所有设置项
'''lpString String，指定为这个项写入的字串值。用vbNullString表示删除这个项现有的字串
'''lpFileName String，初始化文件的名字。如果没有指定完整路径名，则windows会在windows目录查找文件。如果文件没有找到，则函数会创建它
'''其他
'''在vb的api文本查看器里复制的声明如下:
'''Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long


Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize 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 Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (LpBrowseInfo As BROWSEINFO) As Long
Public Declare Function SHGetPathFromIDlist Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)


Public Type BROWSEINFO
  hOwner As Long
  pidlroot As Long
  pszDisplayName As String
  lpszTitle As String
  ulFlags As Long
  lpfn As Long
  lParam As Long
  iImage As Long
 End Type

Public Function GetIniFile(ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As String
    On Error GoTo ErrorHandler

    Dim ItemName As String
    Dim i As Integer
    lpReturnedString = String(nSize, " ")
    GetPrivateProfileString lpApplicationName, lpKeyName, "", lpReturnedString, nSize, lpFileName
    i = 1
    ItemName = ""
    Do While Asc(Mid(lpReturnedString, i, 1)) <> 0
        ItemName = ItemName + Mid(lpReturnedString, i, 1)
        i = i + 1
    Loop
    GetIniFile = ItemName
    
   Exit Function
ErrorHandler:
MsgBox Err.Number & ":" & Err.Description, vbOKOnly + vbCritical


End Function
'*******************************************
'弹出窗体，选择路径
'Public Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (LpBrowseInfo As BROWSEINFO) As Long
'Public Declare Function SHGetPathFromIDlist Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
'Public Type BROWSEINFO
'  hOwner As Long
'  pidlroot As Long
'  pszDisplayName As String
'  lpszTitle As String
'  ulFlags As Long
'  lpfn As Long
'  lparam As Long
'  iImage As Long
' End Type
 
'调用方式
'FilePath=GetFolder("打开一个目录", Form1.hwnd)
Public Function GetFolder(Optional Title As String, Optional hwnd) As String

    Dim bi As BROWSEINFO
    Dim pidl As Long
    Dim folder As String
     
   folder = Space(255)
        
   With bi
      If IsNumeric(hwnd) Then .hOwner = hwnd
      .ulFlags = BIF_RETURNONLYFSDIRS
      .pidlroot = 0

         .lpszTitle = "请选择路径" & Chr$(0)
'   Select Path    选择路径

   End With
   
   pidl = SHBrowseForFolder(bi)
   If SHGetPathFromIDlist(ByVal pidl, ByVal folder) Then
       GetFolder = Left(folder, InStr(folder, Chr$(0)) - 1)
   Else
       GetFolder = ""
   End If
End Function
'判断输入的是否汉字
Public Function IfChn(InText As String) As Boolean
    Static SStr As String
    Dim i As Integer
    Dim TempFile, TempFileBinary, tmpStr As String
    Dim TotalNum, L As Long
    TotalNum = 0
    L = Len(InText)
    For i = 1 To L
        tmpStr = StrConv(Mid$(InText, i, 1), vbWide)
        If Asc(Mid$(InText, i, 1)) < 0 Then
            TotalNum = TotalNum + 1
            SStr = InText
        Else
            IfChn = False   '写入的不是汉字！
            InText = Left(InText, Len(InText) - 1)
            Exit Function
        End If
    Next i
'    LblNum.Caption = Str$(TotalNum) + "个汉字"
'    TempFile = App.Path + "\" + "TempSrc.txt"
'    'TempFileBinary = App.Path + "\" + "TempSrcBinary.txt"
'    Open TempFile For Output As #1
'    Print #1, SrcTxt.Text
'    Close #1
    IfChn = True
End Function

Public Sub ExecuteLink(ByVal sLinkTo As String)

    On Error Resume Next
    
    Dim lRet As Long
    Dim lOldCursor As Long
    
    lOldCursor = Screen.MousePointer
    
    Screen.MousePointer = vbHourglass
    lRet = ShellExecute(0, "open", sLinkTo, "", vbNull, 1)
    
    If lRet >= 0 And lRet <= 0 Then
        Screen.MousePointer = vbDefault
        MsgBox "Error Opening Link to " & sLinkTo & vbCrLf & vbCrLf & Err.LastDllError, , "frmAbout::ExecuteLink"
    End If
    Screen.MousePointer = vbDefault

End Sub