frmmain.frm

煤炭销售管理系统.完成煤炭销售的日常管理工作,和重车计量系统空车计量系统配合使用.

      End
      Begin VB.Menu mnuHelpSearchForHelpOn 
         Caption         =   "搜索帮助主题(&S)..."
      End
      Begin VB.Menu mnuHelpBar0 
         Caption         =   "-"
      End
      Begin VB.Menu mnuHelpAbout 
         Caption         =   "关于(&A) "
      End
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Const NAME_COLUMN = 0
Const TYPE_COLUMN = 1
Const SIZE_COLUMN = 2
Const DATE_COLUMN = 3
Private Enum ObjectType
    otNone = 0
    otFactory = 1
    otGroup = 2
    otPerson = 3
    otFactory2 = 4
    otGroup2 = 5
    otPerson2 = 6
End Enum

Private SourceNode As Object
Private SourceType As ObjectType
Private TargetNode As Object
Private Declare Function OSWinHelp% Lib "user32" Alias "WinHelpA" (ByVal hwnd&, ByVal HelpFile$, ByVal wCommand%, dwData As Any)
  Dim data As ADODB.Connection
  Dim rest As ADODB.Recordset
  Dim rest1 As ADODB.Recordset
Dim mbMoving As Boolean
Const sglSplitLimit = 500

Private Sub Form_Load()
On Error Resume Next
    Dim recc As Integer
     Dim recc1 As Integer
  
    Dim ii As Integer
    Dim i As Integer
    Dim factory As Node
    Dim group1 As Node
    Dim person1 As Node
  Dim jj As Integer
    Me.Left = GetSetting(App.Title, "Settings", "MainLeft", 1000)
    Me.Top = GetSetting(App.Title, "Settings", "MainTop", 1000)
    Me.Width = GetSetting(App.Title, "Settings", "MainWidth", 6500)
    Me.Height = GetSetting(App.Title, "Settings", "MainHeight", 6500)
    Set data = New ADODB.Connection
    data.ConnectionString = "dsn=dzqch"
    data.Open
    Set rest = New ADODB.Recordset
      Set rest1 = New ADODB.Recordset
    rest.Open "select DISTINCT  fhdw from htk where fhdw>''", data, adOpenStatic
    recc = rest.RecordCount
      Set factory = Me.tvTreeView.Nodes.Add(, , "发货单位", "发货单位", otFactory, 1)
  
    For ii = 1 To recc
      Set group1 = Me.tvTreeView.Nodes.Add(factory, tvwChild, , rest.Fields(0), otGroup, 1)
        group1.EnsureVisible
         rest1.Open "select DISTINCT  hth from htk where fhdw='" & group1 & "'", data, adOpenStatic
    
         recc1 = rest1.RecordCount
        'If recc1 >= 1 Then
          For jj = 1 To recc1
         Set person1 = Me.tvTreeView.Nodes.Add(group1, tvwChild, , rest1.Fields(0).Value, 3)
          rest1.MoveNext
            'person1.EnsureVisible
         Next jj
        ' End If
          rest1.Close
    rest.MoveNext
'  person.EnsureVisible

    Next ii
       
    rest.Close
      
End Sub



Private Sub Form_Unload(Cancel As Integer)
    Dim i As Integer


    'close all sub forms
    For i = Forms.Count - 1 To 1 Step -1
        Unload Forms(i)
    Next
    If Me.WindowState <> vbMinimized Then
        SaveSetting App.Title, "Settings", "MainLeft", Me.Left
        SaveSetting App.Title, "Settings", "MainTop", Me.Top
        SaveSetting App.Title, "Settings", "MainWidth", Me.Width
        SaveSetting App.Title, "Settings", "MainHeight", Me.Height
    End If
    'SaveSetting App.Title, "Settings", "ViewMode", lvListView.View
End Sub



Private Sub Form_Resize()
    On Error Resume Next
    If Me.Width < 3000 Then Me.Width = 3000
    SizeControls imgSplitter.Left
End Sub


Private Sub imgSplitter_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    With imgSplitter
        picSplitter.Move .Left + 50, .Top, .Width \ 2, .Height - 20
    End With
    picSplitter.Visible = True
    mbMoving = True
End Sub


Private Sub imgSplitter_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    Dim sglPos As Single
    

    If mbMoving Then
        sglPos = x + imgSplitter.Left
        If sglPos < sglSplitLimit Then
            picSplitter.Left = sglSplitLimit
        ElseIf sglPos > Me.Width - sglSplitLimit Then
            picSplitter.Left = Me.Width - sglSplitLimit
        Else
            picSplitter.Left = sglPos
        End If
    End If
End Sub


Private Sub imgSplitter_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    SizeControls picSplitter.Left
    picSplitter.Visible = False
    mbMoving = False
End Sub


Private Sub TreeView1_DragDrop(Source As Control, x As Single, y As Single)
    If Source = imgSplitter Then
        SizeControls x
    End If
End Sub


Sub SizeControls(x As Single)
    On Error Resume Next
    

    '设置 Width 属性
    If x < 1500 Then x = 1500
    If x > (Me.Width - 1500) Then x = Me.Width - 1500
    tvTreeView.Width = x
    imgSplitter.Left = x
    lvListView.Left = x + 240
    lvListView.Width = Me.Width - (tvTreeView.Width + 140)
    lblTitle(0).Width = tvTreeView.Width
    lblTitle(1).Left = lvListView.Left + 20
    lblTitle(1).Width = lvListView.Width - 40


    '设置 Top 属性
  

    If tbToolBar.Visible Then
        tvTreeView.Top = tbToolBar.Height + picTitles.Height
    Else
        tvTreeView.Top = picTitles.Height
    End If

  lvListView.Top = tvTreeView.Top
    

    '设置 height 属性
    If sbStatusBar.Visible Then
        tvTreeView.Height = Me.ScaleHeight - (picTitles.Top + picTitles.Height + sbStatusBar.Height)
    Else
        tvTreeView.Height = Me.ScaleHeight - (picTitles.Top + picTitles.Height)
    End If
    

    lvListView.Height = tvTreeView.Height
    imgSplitter.Top = tvTreeView.Top
    imgSplitter.Height = tvTreeView.Height
End Sub

Private Sub tbToolBar_ButtonClick(ByVal Button As MSComCtlLib.Button)
    On Error Resume Next
    Select Case Button.Key
        Case "返回"
            '应做:添加 '返回' 按钮代码。
            MsgBox "添加 '返回' 按钮代码。"
        Case "向前"
            '应做:添加 '向前' 按钮代码。
            MsgBox "添加 '向前' 按钮代码。"
        Case "剪切"
            mnuEditCut_Click
        Case "复制"
            mnuEditCopy_Click
        Case "粘贴"
            mnuEditPaste_Click
        Case "删除"
            mnuFileDelete_Click
        Case "属性"
            mnuFileProperties_Click
        Case "大图标"
            lvListView.View = lvwIcon
        Case "小图标"
            lvListView.View = lvwSmallIcon
        Case "列表"
            lvListView.View = lvwList
        Case "详细资料"
            lvListView.View = lvwReport
    End Select
End Sub

Private Sub mnuHelpAbout_Click()
    MsgBox "版本 " & App.Major & "." & App.Minor & "." & App.Revision
End Sub

Private Sub mnuHelpSearchForHelpOn_Click()
    Dim nRet As Integer


    '如果这个工程没有帮助文件，显示消息给用户
    '可以在“工程属性”对话框中为应用程序设置帮助文件
    If Len(App.HelpFile) = 0 Then
        MsgBox "无法显示帮助目录，该工程没有相关联的帮助。", vbInformation, Me.Caption
    Else

    On Error Resume Next
        nRet = OSWinHelp(Me.hwnd, App.HelpFile, 261, 0)
        If Err Then
            MsgBox Err.Description
        End If
    End If

End Sub

Private Sub mnuHelpContents_Click()
    Dim nRet As Integer


    '如果这个工程没有帮助文件，显示消息给用户
    '可以在“工程属性”对话框中为应用程序设置帮助文件
    If Len(App.HelpFile) = 0 Then
        MsgBox "无法显示帮助目录，该工程没有相关联的帮助。", vbInformation, Me.Caption
    Else
        On Error Resume Next
        nRet = OSWinHelp(Me.hwnd, App.HelpFile, 3, 0)
        If Err Then
            MsgBox Err.Description
        End If
    End If

End Sub


Private Sub mnuToolsOptions_Click()
    frmOptions.Show vbModal, Me
End Sub

Private Sub mnuViewWebBrowser_Click()
    '应做:添加 'mnuViewWebBrowser_Click' 代码。
    MsgBox "添加 'mnuViewWebBrowser_Click' 代码。"
End Sub

Private Sub mnuViewOptions_Click()
    frmOptions.Show vbModal, Me
End Sub

Private Sub mnuViewRefresh_Click()
    '应做:添加 'mnuViewRefresh_Click' 代码。
    MsgBox "添加 'mnuViewRefresh_Click' 代码。"
End Sub



Private Sub mnuVAIByDate_Click()
    'ToDo: 添加 'mnuVAIByDate_Click' 代码
'  lvListView.SortKey = DATE_COLUMN
End Sub


Private Sub mnuVAIByName_Click()
    'ToDo: 添加 'mnuVAIByName_Click' 代码
'  lvListView.SortKey = NAME_COLUMN
End Sub


Private Sub mnuVAIBySize_Click()
    'ToDo: 添加 'mnuVAIBySize_Click' 代码
'  lvListView.SortKey = SIZE_COLUMN
End Sub


Private Sub mnuVAIByType_Click()
    'ToDo: 添加 'mnuVAIByType_Click' 代码
'  lvListView.SortKey = TYPE_COLUMN
End Sub

Private Sub mnuViewStatusBar_Click()
    mnuViewStatusBar.Checked = Not mnuViewStatusBar.Checked
    sbStatusBar.Visible = mnuViewStatusBar.Checked
    SizeControls imgSplitter.Left
End Sub

Private Sub mnuViewToolbar_Click()
    mnuViewToolbar.Checked = Not mnuViewToolbar.Checked
    tbToolBar.Visible = mnuViewToolbar.Checked
    SizeControls imgSplitter.Left
End Sub

Private Sub mnuEditInvertSelection_Click()
    '应做:添加 'mnuEditInvertSelection_Click' 代码。
    MsgBox "添加 'mnuEditInvertSelection_Click' 代码。"
End Sub

Private Sub mnuEditSelectAll_Click()
    '应做:添加 'mnuEditSelectAll_Click' 代码。
    MsgBox "添加 'mnuEditSelectAll_Click' 代码。"
End Sub

Private Sub mnuEditPasteSpecial_Click()
    '应做:添加 'mnuEditPasteSpecial_Click' 代码。
    MsgBox "添加 'mnuEditPasteSpecial_Click' 代码。"
End Sub

Private Sub mnuEditPaste_Click()
    '应做:添加 'mnuEditPaste_Click' 代码。
    MsgBox "添加 'mnuEditPaste_Click' 代码。"
End Sub

Private Sub mnuEditCopy_Click()
    '应做:添加 'mnuEditCopy_Click' 代码。
    MsgBox "添加 'mnuEditCopy_Click' 代码。"
End Sub

Private Sub mnuEditCut_Click()
    '应做:添加 'mnuEditCut_Click' 代码。
    MsgBox "添加 'mnuEditCut_Click' 代码。"
End Sub

Private Sub mnuEditUndo_Click()
    '应做:添加 'mnuEditUndo_Click' 代码。
    MsgBox "添加 'mnuEditUndo_Click' 代码。"
End Sub

Private Sub mnuFileClose_Click()
    '卸载窗体
    Unload Me

End Sub

Private Sub mnuFileProperties_Click()
    '应做:添加 'mnuFileProperties_Click' 代码。
    MsgBox "添加 'mnuFileProperties_Click' 代码。"
End Sub

Private Sub mnuFileRename_Click()
    '应做:添加 'mnuFileRename_Click' 代码。
    MsgBox "添加 'mnuFileRename_Click' 代码。"
End Sub

Private Sub mnuFileDelete_Click()
    '应做:添加 'mnuFileDelete_Click' 代码。
    MsgBox "添加 'mnuFileDelete_Click' 代码。"
End Sub

Private Sub mnuFileNew_Click()
    '应做:添加 'mnuFileNew_Click' 代码。
    MsgBox "添加 'mnuFileNew_Click' 代码。"
End Sub

Private Sub mnuFileSendTo_Click()
    '应做:添加 'mnuFileSendTo_Click' 代码。
    MsgBox "添加 'mnuFileSendTo_Click' 代码。"
End Sub

Private Sub mnuFileFind_Click()
    '应做:添加 'mnuFileFind_Click' 代码。
    MsgBox "添加 'mnuFileFind_Click' 代码。"
End Sub

Private Sub mnuFileOpen_Click()
    Dim sFile As String


    With dlgCommonDialog
        .DialogTitle = "打开"
        .CancelError = False
        'ToDo: 设置 common dialog 控件的标志和属性
        .Filter = "所有文件 (*.*)|*.*"
        .ShowOpen
        If Len(.FileName) = 0 Then
            Exit Sub
        End If
        sFile = .FileName
    End With
    'ToDo: 添加处理打开的文件的代码

End Sub

Private Sub tvTreeView_DblClick()
On Error Resume Next
 MsgBox tvTreeView.SelectedItem.Text + "," + tvTreeView.SelectedItem.FullPath

End Sub

Private Sub tvTreeView_DragDrop(Source As Control, x As Single, y As Single)
If SourceNode Is Nothing Then Exit Sub

    If Not (tvTreeView.DropHighlight Is Nothing) Then
        ' It's a valid drop. Set source node's
        ' parent to be the target node.
        Set SourceNode.Parent = tvTreeView.DropHighlight
        Set tvTreeView.DropHighlight = Nothing
    End If

    Set SourceNode = Nothing
    SourceType = otNone
End Sub

Private Sub tvTreeView_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
Set SourceNode = tvTreeView.HitTest(x, y)
End Sub

Private Sub tvTreeView_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
If SourceNode Is Nothing Then Exit Sub

    If Button = vbLeftButton Then
           SourceType = NodeType(SourceNode)
   Set tvTreeView.SelectedItem = SourceNode
'  tvTreeView.DragIcon = Me.ImageList1(SourceType + 1)
        tvTreeView.Drag vbBeginDrag
    End If
End Sub
Private Function NodeType(test_node As Node) As ObjectType
    If test_node Is Nothing Then Exit Function
    Select Case Left$(test_node.Key, 1)
        Case "f"
            NodeType = otFactory
        Case "g"
            NodeType = otGroup
        Case "p"
            NodeType = otPerson
    End Select
End Function