bas_func.bas

生产计划管理等信息 可以查询计划完成情况等

Attribute VB_Name = "Bas_Func"
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 GetDesktopWindow Lib "user32" () 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

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
Public 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

Function GetIniInfo(ByVal FileName As String, ByVal Section As String, ByVal KeyName As String, Optional ByVal Default As Variant, Optional ByVal ByValue As Boolean) As Variant
  '从文件中读取INI信息
  Dim strDefault As String
  Dim Result As String
  Dim ValueLen As Long
  Dim msg As String
  
  On Error Resume Next
  strDefault = Default
  ValueLen = 4096
  Result = Space$(ValueLen)
  ValueLen = GetPrivateProfileString(Section, KeyName, strDefault, Result, ValueLen, FileName)
  If ByValue Then
    GetIniInfo = Val(Result)
  Else
    Result = Trim(Result)
    If Asc(Right(Result, 1)) = 0 Then Result = Left(Result, Len(Result) - 1)
    GetIniInfo = Trim(Result)
  End If
End Function

Sub SaveIniInfo(ByVal FileName As String, ByVal Section As String, ByVal KeyName As String, ByVal Value As Variant)
  '向文件中写Ini信息
  Dim strValue As String
  strValue = Value
  WritePrivateProfileString Section, KeyName, strValue, FileName
End Sub


'''错误信息显示
Public Sub ErrDescription(MsgDescription As String, ModuleName As String, FunctionOrSubName As String)
  Dim ErrorStr As String
  ErrorStr = "程序错误" & vbCrLf & vbCrLf & vbCrLf
  ErrorStr = ErrorStr & "错误内容:" & MsgDescription & vbCrLf & vbCrLf
  ErrorStr = ErrorStr & "所属模块:" & ModuleName & vbCrLf & vbCrLf
  ErrorStr = ErrorStr & "过程名称:" & FunctionOrSubName & vbCrLf & vbCrLf
  MsgBox ErrorStr, vbInformation, "程序错误"
End Sub

Public Function AddZero(Num As Integer) As String
    '在前边加 Num 个 0
    AddZero = ""
    Dim i As Variant
    For i = 1 To Num
      AddZero = "0" & AddZero
    Next i
End Function

Sub txtSelAll(txt As Control)
'设置文本框中内容为全选,主要用于Text_GotFocus
  If gtxtSelAllIgnore Then Exit Sub
  With txt
    .SelStart = 0
    .SelLength = Len(.Text)
  End With
End Sub


Public Function GetItem(ByVal msg As String, ByVal Split As String, ByVal Index As Long, Optional ByVal ByValue As Boolean) As Variant
    '取指定项,EX: GetItem("1A,5A,10A,20A",",",2) = "10A"
    'Index = -1 , Get Items Count
    Dim SplitLen As Long
    Dim S As Long
    Dim N As Long
    Dim Count As Long
    Dim Item As String
    
    SplitLen = Len(Split)
    If Len(msg) * SplitLen > 0 Then   '有效的字符串和分隔符
      S = 1
      If Index < 0 Then   '取项数
        Do
          N = InStr(S, msg, Split)
          Count = Count + 1
          If N > 0 Then S = N + SplitLen
        Loop Until (N = 0)
        GetItem = Count
      Else                '取指定项
        Do
          N = InStr(S, msg, Split)
          If Count = Index Then
            Item = Mid(msg, S, IIf(N = 0, Len(msg), N - S))
            Exit Do
          Else
            Count = Count + 1
            If N > 0 Then S = N + SplitLen
          End If
        Loop Until (N = 0)
        If ByValue Then
          GetItem = Val(Item)
        Else
          GetItem = Item
        End If
      End If
    End If
End Function

'启动外部程序或文档
Public Function StartDoc(DocName As String) As Long
  Dim Scr_hDC As Long
  Scr_hDC = GetDesktopWindow()
  StartDoc = ShellExecute(Scr_hDC, "Open", DocName, "", "C:\", 1)
End Function