frmstock.frm

雨点进销存软件,绝对可以用,大家可以拿来使用

End Sub

'设置TreeView
Public Function SetTVMain(CmdNum As Integer, ActiveCmdIdx As Integer, ChangeActive As Boolean, CmdHeight As Long) As Boolean
On Error GoTo Err

Dim i As Integer
Dim CmdCaption As String '按钮标题
Dim tHeight, CmdTotalHeight As Long '临时高度变量

If CmdNum <= 0 Then CmdNum = CmdMain.Count

''''''''''检验？？？？？？？？？？？
'增加、减少按钮
If CmdNum > CmdMain.Count Then
   
   For i = CmdMain.Count To CmdNum - 1
       
       If GetCmdCaption(i, CmdCaption) = False Then
       End If
       Load CmdMain(i)
       CmdMain(i).Visible = True
   
   Next i

ElseIf CmdNum < CmdMain.Count Then
   
   For i = CmdMain.Count - 1 To CmdNum
       Unload CmdMain(i)
   Next i

End If

'获取应置为活动的按钮Index
If CmdHeight <> 0 Then CmdMain(0).Height = CmdHeight

If ChangeActive = False Then
   
   ActiveCmdIdx = 0
   For i = 0 To CmdMain.Count - 1
       If CmdMain(i).FontBold = True Then ActiveCmdIdx = i
   Next i

Else
   
   If ActiveCmdIdx < 0 Or ActiveCmdIdx > CmdNum - 1 Then
      ActiveCmdIdx = 0
   End If
   If CmdMain(ActiveCmdIdx).Visible = False Then ActiveCmdIdx = 0

End If

CmdMain(ActiveCmdIdx).Visible = True

'设置PicMain中控件位置
tHeight = 0
For i = 0 To CmdNum - 1
   If CmdMain(i).Visible = True Then
      CmdTotalHeight = CmdTotalHeight + CmdMain(0).Height
   End If
Next i
For i = 0 To CmdNum - 1
   CmdMain(i).FontBold = False
   CmdMain(i).BackColor = &H8000000F
   If CmdMain(i).Visible = True Then
      CmdMain(i).Move 20, tHeight, PicMain.Width - 70, CmdMain(0).Height
      tHeight = tHeight + CmdMain(0).Height
      If ActiveCmdIdx = i Then
         CmdMain(i).FontBold = True
         CmdMain(i).BackColor = &HC0C0FF        '&HC0FFC0
         If i = CmdNum - 1 Then
           TVMain.Move 0, tHeight, PicMain.Width, PicMain.Height - CmdTotalHeight
         Else
           TVMain.Move 0, tHeight, PicMain.Width, PicMain.Height - CmdTotalHeight - 60
         End If
         tHeight = tHeight + TVMain.Height
      End If
   End If
Next i
Err:
End Function
Public Sub FrmInit()
On Error GoTo Err
Dim gRd As Recordset
Dim i As Integer
Dim m As Integer

TVMain.Nodes.Clear
'Set gRst = gdbs.openrecordset("select tree_type,tree_name from tree_defination where tree_user_name is null or tree_user_name='" + gUserName + "' group by tree_type,tree_name", 2,2048,3)
Set gRd = gDbFish.OpenRecordset("select is_boot,Field_Name_CH from field_name where field_name_type='5' group by is_boot,Field_Name_CH")
i = 0
While Not gRd.EOF
i = i + 1
gRd.MoveNext
Wend
Call SetTVMain(i, 0, False, 0)
gRd.Close

Set gRd = gDbFish.OpenRecordset("select is_boot,Field_Name_CH,Field_Name_EN from field_name where field_name_type='5' group by is_boot,Field_Name_CH,Field_Name_EN")
m = 0
While Not gRd.EOF
   CmdMain(m).Caption = Trim(gRd.Fields("field_name_ch"))
   Table_Type = Trim(gRd.Fields("Field_Name_EN"))     '获得

   CmdMain(m).Tag = ConvertNull(gRd.Fields("is_boot"))
   m = m + 1
'   If rd.AbsolutePosition > 0 Then Call AddControl(m_Tree(rd.AbsolutePosition))
'   m_Tree(rd.AbsolutePosition).Visible = True
'   m_Tree(rd.AbsolutePosition).Caption = Trim(rd.Fields("field_name_ch"))
'   m_Tree(rd.AbsolutePosition).Tag = ConvertNull(rd.Fields("field_name_type"))
   gRd.MoveNext
Wend
CmdMain(0).Value = True
'm_Tree(0).Checked = True

Err:
End Sub

'**************************************************************************
'获取按钮标题，即Tree_Name
'**************************************************************************
Public Function GetCmdCaption(CmdIndex As Integer, CmdCaption As String) As Boolean
On Error GoTo Err
CmdCaption = CStr(CmdIndex)
GetCmdCaption = True
Exit Function
Err:
  GetCmdCaption = False
End Function

Private Sub CmdFind_Click()
Unload Me
FrmFind.Show
End Sub

Private Sub TVMain_Show(FindType As String, m As Integer)
   Dim i As Integer
'   Dim stna As String
   Dim a As String
   Dim nodX As Node
   Dim rd As Recordset
   Dim sql As String
   
   i = 1
   TVMain.Nodes.Clear
   TVMain.LineStyle = tvwTreeLines
   TVMain.ImageList = ImgTree
   
   sql = "select * from " + "" + Trim(FindType) + ""
   Set rd = gDbFish.OpenRecordset(sql)
   
   
   Set nodX = TVMain.Nodes.Add(, , "r", "全部")

'   rd.MoveFirst
 While Not rd.EOF
   If i = 1 Then
      TVMain.Nodes(i).Image = 1
   Else
      TVMain.Nodes(i).Image = 2
   End If
   a = i
   Set nodX = TVMain.Nodes.Add("r", tvwChild, "child" + a, Trim(rd.Fields(m)))
   i = i + 1
  
   rd.MoveNext
 Wend
       TVMain.Nodes(i).Image = 2
       TVMain.Refresh
       rd.Close
    
End Sub



Private Sub CmdMain_Click(Index As Integer)
Dim CmdCaption As String
Dim i As Integer

On Error GoTo Err
Me.MousePointer = vbHourglass '设置鼠标
'LVFile.ColumnHeaders.Clear
LVFile.ListItems.Clear
Call SetTVMain(0, Index, True, 0) '设置按钮位置
DoEvents
'Call ViewTreeRoot(CInt(CmdMain(Index).Tag), CmdCaption)


While Not CmdMain(Index).Caption = ""

  Select Case CmdMain(Index).Caption
         Case "入库情况"
           Field_Type = 1
           Table_Type = "product_in"
           GoTo AddLVFileField:
         Case "出库情况"
           Field_Type = 2
           Table_Type = "product_out"
           GoTo AddLVFileField:
         Case "库存情况"
           Field_Type = 3
           Table_Type = "product_stock"
           GoTo AddLVFileField:
  End Select



Wend

AddLVFileField:
Call AddLVFileField(Field_Type)



Err:
Me.MousePointer = vbDefault
End Sub


Private Sub Form_Activate()
On Error GoTo Err

Call Form_Resize
Call FrmInit
'Call CmdMain_Click
'Call SetTVMain(0, Index, True, 0) '设置按钮位置
Err:
End Sub

Private Sub Form_Load()
'Call FrmInit
'Call TVMain_Show
End Sub


Private Sub Form_Resize()

If Me.WindowState = 1 Then Exit Sub
If Me.Width < 8000 Then Me.Width = 8000
If Me.Height < 5000 Then Me.Height = 5000
If gWidthRate = 0 Then gWidthRate = 0.2 '水平控件比例
If gHeightRate = 0 Then gHeightRate = 0.6 '垂直控件比例
Frame.Move 0, Tbar.Height + 20, Me.ScaleWidth * gWidthRate, _
            1300
'             Me.ScaleHeight * 0.13
OptionFactory.Move 40, (Frame.Height - 2 * OptionFactory.Height) / 2 + 120
OptionType.Move 40, OptionFactory.Top + OptionFactory.Height + 120
PicMain.Move 0, Tbar.Height + Frame.Height + 20, Me.ScaleWidth * gWidthRate, _
             Me.ScaleHeight - Tbar.Height - SBar.Height - Frame.Height
PicFile.Move PicMain.Width, Tbar.Height + 60, Me.ScaleWidth * 0.8, _
             Me.ScaleHeight - Tbar.Height - SBar.Height
LVFile.Move 60, 60, Me.ScaleWidth * 0.8 - 60, _
             Me.ScaleHeight - Tbar.Height - SBar.Height - 60
End Sub


Private Sub Form_Unload(Cancel As Integer)
Call FrmMain.CmdQuit_Click
End Sub

Private Sub OptionFactory_Click()
On errror GoTo Err
Dim Find_Type As String
Dim i As Integer

TVMain.Nodes.Clear
If OptionFactory.Value = True Then
   Find_Type = "factory_info"
   i = 0
   Find_Field_Type = "pd_factory"
End If
Call TVMain_Show(Find_Type, i)
Err:
End Sub

Private Sub OptionType_Click()
On errror GoTo Err
Dim Find_Type As String
Dim i As Integer
TVMain.Nodes.Clear
If OptionType.Value = True Then
   Find_Type = "product_kind"
   i = 1
   Find_Field_Type = "pd_type"
End If

Call TVMain_Show(Find_Type, i)
Err:
End Sub



'显示LVFile里的字段
Private Sub AddLVFileField(Field_Type As String)
 Dim rd As Recordset
 Dim sql As String
 Dim i As String
 LVFile.ColumnHeaders.Clear
 
 If Field_Type = 1 Then
   sql = "select * from field_name where  field_name_type='1'"
 ElseIf Field_Type = 2 Then
   sql = "select * from field_name where field_name_type='2'"
 ElseIf Field_Type = 3 Then
    sql = "select * from field_name where field_name_type='3'"
 End If
 Set rd = gDbFish.OpenRecordset(sql)
 

 While Not rd.EOF
 
'  LVFile.ListItems.Add , "@F " + rd.Fields("field_name_en"), Trim(rd.Fields("field_name_ch"))
  LVFile.ColumnHeaders.Add , rd.Fields("field_name_en"), Trim(rd.Fields("field_name_ch"))

  
  rd.MoveNext
 Wend
 

End Sub




Private Sub Tbar_ButtonClick(ByVal Button As MSComctlLib.Button)
Select Case Button.Key
   Case "tbFind"
       Me.Hide
       FrmFind.Show 1
   Case "tbBack"
       Me.Hide
       FrmMain.Show 1
   Case "tbQuit"
       Call FrmMain.CmdQuit_Click
End Select
End Sub

Private Sub TVMain_NodeClick(ByVal Node As MSComctlLib.Node)
Dim tNode As Node '临时节点


LVFile.ListItems.Clear
SBar.Panels(2).Text = ""

Me.MousePointer = vbHourglass '设置鼠标

Set tNode = Node.Child
gRfshNode = True
If gRfshNode = True Then '强制刷新节点 'tNode Is Nothing Or
    
    Node.Selected = True
'    Call RfshNode(Node, True)
    Node.Expanded = True
Else
    Node.Expanded = Not (Node.Expanded)
End If

'显示文件列表
Call View_File(LVFile, Node, SBar.Panels(2), SBar.Panels(3))
'Call List_View_File(Nothing, LVFile, Node, SBar.Panels(2), SBar.Panels(4))

Me.MousePointer = vbDefault
End Sub

Public Function View_File(p_ListCtl As ListView, p_Node As Node, SBarPanel1 As Panel, SBarPanel2 As Panel)
Dim rd As Recordset
Dim sql As String
Dim tListItem As ListItem
Dim CmdCaption As String
Dim Num As String

If p_Node = "全部" Then
  sql = "select * from " + Table_Type + ""
Else
  sql = "select * from " + Table_Type + " where " + Find_Field_Type + "='" + p_Node + "'"
End If



Num = 0
Set rd = gDbFish.OpenRecordset(sql)

While Not rd.EOF

        
        '添加第一列
        Set tListItem = p_ListCtl.ListItems.Add(, , Trim(rd.Fields(2)))

        '添加其余列
        For i = 3 To p_ListCtl.ColumnHeaders.Count
            tListItem.SubItems(i - 2) = (Trim(rd.Fields(p_ListCtl.ColumnHeaders(i).Index)))
'            ConvertFieldValue(tRst.Fields(p_ListCtl.ColumnHeaders(i).Text), CInt(p_ListCtl.ColumnHeaders(i).Tag), Mid(p_ListCtl.ColumnHeaders(i).Key, 5), 0)
        Next i


rd.MoveNext
Num = Num + 1
'If Not SBarPanel1 Is Nothing Then SBarPanel1.Text = "进度：" + Format(rd.AbsolutePosition / rd.RecordCount, "00.00%")
Wend
If Not SBarPanel2 Is Nothing Then SBarPanel2.Text = "记录数: " + Trim(Num)
If Not SBarPanel1 Is Nothing Then SBarPanel1.Text = "进度：完成"
End Function