frmchoose.frm

星级酒店管理系统（附带系统自写控件源码）

Public Function GetIDs(sName As String) As String
 
 Dim DB As Connection
 Dim Rec As Recordset
 
 On Error Resume Next
 Set DB = CreateObject("ADODB.Connection")
 Set Rec = CreateObject("ADODB.Recordset")
     DB.ConnectionString = ConStr
     DB.Open
     Rec.ActiveConnection = DB
     
     Rec.Open "Select * from tbdProduction where fldpropath Like '" & sName & "\%'", , adOpenStatic, adLockReadOnly, adCmdText
     
 If Not (Rec.BOF And Rec.EOF) Then
    Do While Not Rec.EOF
       GetIDs = ",'" & Rec.Fields("fldproid") & "'" & GetIDs
       Rec.MoveNext
    Loop
   Else
   '没有找到该项目时
    GetIDs = ""
    Rec.Close
    DB.Close
    Exit Function
 End If
 If Left(GetIDs, 2) = ",'" Then
    GetIDs = Right(GetIDs, Len(GetIDs) - 1)
 End If
 Rec.Close
 DB.Close
 
End Function

Private Sub Form_Activate()

'显示产品或用户列表数据
On Error GoTo Err1

lstResult.Clear
Set DB = CreateObject("ADODB.Connection")
Set Rec = CreateObject("ADODB.Recordset")

    DB.ConnectionString = ConStr
    DB.Open
    Rec.ActiveConnection = DB
    
    Rec.Open strRecName, , adOpenStatic, adLockReadOnly, adCmdText
    
    Dim strTemp As String
    Dim nOX As Integer
    Dim RecStore As Recordset
    Dim DbStore As Connection
    Dim lngNumber As Long
    Dim sBBs As String
    Dim IsFolder As Boolean
    Dim LenID As Integer   '产品ID长度
    Dim sCondition As String  '条件
    Dim sPID As String  '产品ID
    nOX = GetPos(StrProId)

Set RecStore = CreateObject("ADODB.Recordset")
    RecStore.ActiveConnection = DB
            
Select Case strType
   'OK产品选择时,
    Case "Production"
        Set DbStore = CreateObject("ADODB.Connection")
            DbStore.ConnectionString = ConStr
            DbStore.Open
        If Rec.EOF And Rec.BOF Then
        Else
            Rec.MoveFirst
            Do While Not Rec.EOF
                sPID = Trim(Rec("fldproid"))  '给出产品ID
                LenID = Len(sPID)
                strTemp = Right$(sPID, LenID - Len(StrProId) + nOX)
                IsFolder = Not Rec("fldtruepro")
               '如果为目录时,必须统计子目录及产品的所有库存之后
                If IsFolder = True Then
                  '首先给出该产品的集合
                   sCondition = GetIDs(StrProId & strTemp)
                   If sCondition = "" Then
                      '没有产品记录时
                       lngNumber = 0
                    Else
                       
                       RecStore.Open "Select sum(fldnumber) from tbdstore Where fldproid in(" & sCondition & ")", , adOpenStatic, adLockReadOnly, adCmdText
                       If Not RecStore.EOF() Then
                          lngNumber = NullValue(RecStore.Fields(0))
                          Else
                          lngNumber = 0
                       End If
                       
                       RecStore.Close
                   
                   End If
                  '添加到列表中
                   sBBs = "〓" & NullValue(Rec("fldproname")) + " (" + NullValue(Rec("fldprocolor")) + ")"   '目录标志
                   lstResult.AddItem strTemp + Space(12 - Len(strTemp)) + sBBs + Space(53 - Len(sBBs) - 12) + "库存:[" & lngNumber & "]"
                 Else
                   
                    RecStore.Open "Select sum(fldNumber) From tbdStore Where fldProID='" & sPID & "'", , adOpenStatic, adLockReadOnly, adCmdText
                    If Not RecStore.EOF() Then
                       lngNumber = NullValue(RecStore.Fields(0))
                      Else
                       lngNumber = 0
                    End If
                   '添加到列表中
                    sBBs = "◇" & NullValue(Rec("fldproname")) + " (" + NullValue(Rec("fldprocolor")) + ")"
                    lstResult.AddItem strTemp + Space(12 - Len(strTemp)) + sBBs + Space(53 - 12 - Len(sBBs)) + "库存:[" & lngNumber & "]"
                    
                    RecStore.Close
                    
                End If
                    Rec.MoveNext
            Loop
        End If
        
        DbStore.Close
        
   '用户选择时=================================================================
    Case "Customer"
        If Not (Rec.EOF And Rec.BOF) Then
            Rec.MoveFirst
            Do While Not Rec.EOF
               strTemp = Right$(Rec("fldid"), Len(Rec("fldid")) - Len(StrProId) + nOX)
               lstResult.AddItem CStr(strTemp + Space(12 - Len(strTemp)) + NullValue(Rec("fldname")))
               Rec.MoveNext
            Loop
        End If
        '结束===================================================================
    Case Else
        If Rec.EOF And Rec.BOF Then
        Else
            Rec.MoveFirst
            Do While Not Rec.EOF
                lstResult.AddItem Rec(strFieldName)
                Rec.MoveNext
            Loop
        End If
End Select

Rec.Close
DB.Close

Exit Sub
Err1:
    MsgBox "错误！" + Err.Description, vbInformation, MsgBoxtitle
        
End Sub

Private Sub Form_Load()

 On Error Resume Next
 GetFormSet Me, Screen
'初始化路径与返回值
 strValue = ""
 StrPathId = ""
 StrProId = ""
 
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)

 On Error Resume Next
 If UnloadMode = 0 Then
    '从关闭按钮关闭时
    Me.Hide
 End If
 
End Sub

Private Sub Form_Unload(Cancel As Integer)

On Error Resume Next
SaveFormSet Me

End Sub

Private Sub lstResult_DblClick()

  On Error Resume Next
  cmdNew_Click
  
End Sub

Private Sub lstResult_KeyPress(KeyAscii As Integer)

 On Error Resume Next
 If KeyAscii = 13 Then
    Call lstResult_DblClick
 End If
 
End Sub

Private Sub txtInput_Change()

 On Error Resume Next
 lstResult.ListIndex = SendMessage(lstResult.Hwnd, LB_FINDSTRING, -1, ByVal txtInput.Text)

End Sub

Private Sub txtInput_GotFocus()

 On Error Resume Next
 txtInput.SelStart = 0
 txtInput.SelLength = Len(txtInput.Text)
 
End Sub

Private Sub txtInput_KeyDown(KeyCode As Integer, Shift As Integer)

On Error Resume Next
If KeyCode = vbKeyReturn Then
  '调用双击
   Call lstResult_DblClick
End If

End Sub

Public Sub ReservedIT(sPath As String, sPro As String, sType As String)
     
  If sType = "Save" Then
    If chkReserved.Value = vbChecked Then
      Select Case strType
      Case "Production"
        SaveSetting "ClientTrace", "Option", "Production_sPath", sPath
        SaveSetting "ClientTrace", "Option", "Production_sPro", sPro
      Case "Customer"
        SaveSetting "ClientTrace", "Option", "Customer_sPath", sPath
        SaveSetting "ClientTrace", "Option", "Customer_sPro", sPro
      Case "Other"
        SaveSetting "ClientTrace", "Option", "Other_sPath", sPath
        SaveSetting "ClientTrace", "Option", "Other_sPro", sPro
      End Select
     Else
      Select Case strType
      '清空所有
      Case "Production"
        SaveSetting "ClientTrace", "Option", "Production_sPath", ""
        SaveSetting "ClientTrace", "Option", "Production_sPro", ""
      Case "Customer"
        SaveSetting "ClientTrace", "Option", "Customer_sPath", ""
        SaveSetting "ClientTrace", "Option", "Customer_sPro", ""
      Case "Other"
        SaveSetting "ClientTrace", "Option", "Other_sPath", ""
        SaveSetting "ClientTrace", "Option", "Other_sPro", ""
      End Select
    End If
   Else
    If chkReserved.Value = vbChecked Then
       Select Case strType
        Case "Production"
             StrPathId = GetSetting("ClientTrace", "Option", "Production_sPath", "")
             StrProId = GetSetting("ClientTrace", "Option", "Production_sPro", "")
        Case "Customer"
             StrPathId = GetSetting("ClientTrace", "Option", "Customer_sPath", "")
             StrProId = GetSetting("ClientTrace", "Option", "Customer_sPro", "")
        Case "Other"
             StrPathId = GetSetting("ClientTrace", "Option", "Other_sPath", "")
             StrProId = GetSetting("ClientTrace", "Option", "Other_sPro", "")
       End Select
      Else
       '清空所有
        Select Case strType
        Case "Production"
             StrPathId = ""
             StrProId = ""
        Case "Customer"
             StrPathId = ""
             StrProId = ""
        Case "Other"
             StrPathId = ""
             StrProId = ""
       End Select
    End If
  End If
   
  If chkReserved.Value = vbChecked Then
     SaveSetting "ClientTrace", "Option", "Reserved", 1
    Else
     SaveSetting "ClientTrace", "Option", "Reserved", 0
  End If
  
End Sub