frmmain.frm

注释：用VB开发的进销存系统源码

Attribute VB_Exposed = False


Option Explicit

'''''''''''''''''''''''''''''''''''''
Private Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Private Declare Function GetMenuItemID Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Private Declare Function ModifyMenu Lib "user32" Alias "ModifyMenuA" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpString As String) As Long
Private Declare Function SetMenuItemBitmaps Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal hBitmapUnchecked As Long, ByVal hBitmapChecked As Long) As Long

Private Declare Function GetMenuCheckMarkDimensions Lib "user32" () As Long

Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long

Private Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function PatBlt Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal dwRop As Long) As Long

Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long

''''''''''''''''''''''''''''''''''''''''


Private Declare Function OSWinHelp% Lib "user32" Alias "WinHelpA" (ByVal hwnd&, ByVal HelpFile$, ByVal wCommand%, dwData As Any)
'Private Declare Function IsRegistedOrNot Lib "TXAD.dll" (ByVal Reg As String) As Boolean
'Private Declare Function ShowRegForm Lib "TXAD.dll" (ByVal Reg As String)


Private Sub Gradient(TheObject As Object, Redval&, Greenval&, Blueval&, TopToBottom As Boolean)
    'TheObject can be any object that supports the Line method (like forms and pictures).
    'Redval, Greenval, and Blueval are the Red, Green, and Blue starting values from 0 to 255.
    'TopToBottom determines whether the gradient will draw down or up.
    Dim Step%, Reps%, FillTop%, FillLeft%, FillRight%, FillBottom%, HColor$
    'This will create 63 steps in the gradient. This looks smooth on 16-bit and 24-bit color.
    'You can change this, but be careful. You can do some strange-looking stuff with it...
    Step = (TheObject.Height / 63)
    'This tells it whether to start on the top or the bottom and adjusts variables accordingly.
    If TopToBottom = True Then FillTop = 0 Else FillTop = TheObject.Height - Step
    FillLeft = 0
    FillRight = TheObject.Width
    FillBottom = FillTop + Step
    'If you changed the number of steps, change the number of reps to match it.
    'If you don't, the gradient will look all funny.
    For Reps = 1 To 63
        'This draws the colored bar.
        TheObject.Line (FillLeft, FillTop)-(FillRight, FillBottom), RGB(Redval, Greenval, Blueval), BF
        'This decreases the RGB values to darken the color.
        'Lower the value for "squished" gradients. Raise it for incomplete gradients.
        'Also, if you change the number of steps, you will need to change this number.
        Redval = Redval - 4
        Greenval = Greenval - 4
        Blueval = Blueval - 4
        'This prevents the RGB values from becoming negative, which causes a runtime error.
        If Redval <= 0 Then Redval = 0
        If Greenval <= 0 Then Greenval = 0
        If Blueval <= 0 Then Blueval = 0
        'More top or bottom stuff; Moves to next bar.
        If TopToBottom = True Then FillTop = FillBottom Else FillTop = FillTop - Step
        FillBottom = FillTop + Step
    Next
End Sub



Private Sub MDIForm_Load()
    Dim fn As String
    Dim I, j
    Dim hMenu, hSubMenu, menuID, X

    
'    If Not IsRegistedOrNot("LSDStar") Then
'      Select Case ShowRegForm("LSDStar")
'         Case 1
'            MsgBox "注册成功！"
'         Case 2
'            MsgBox "试用"
'         Case 3
'            MsgBox "取消"
'            End
'      End Select
'    End If
    
    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)
    
    Me.Caption = "进销存管理系统---服装鞋业专用版v2000" & GetSetting("LSDSTAR", "程序标题", "进销存管理系统程序标题", "ADSoft")
    
    
    fn = Dir(App.Path & "\" & "Background.bmp")
    If fn = "" Then
        fn = Dir(App.Path & "\" & "Background.jpg")
    End If
    If fn <> "" Then frmMain.Picture = LoadPicture(App.Path & "\" & fn)
    
    fn = Dir(App.Path & "\" & "main.ico")
    If fn <> "" Then frmMain.Icon = LoadPicture(App.Path & "\" & fn)


'    CurtMenu1.Connect Me.hwnd, True, img


'  hMenu = GetMenu(hwnd)
'  For j = 0 To 7
'    hSubMenu = GetSubMenu(hMenu, j) '1 for "Other" menu etcetera
'    For I = 1 To 10
'        menuID = GetMenuItemID(hSubMenu, I - 1)
'        On Error Resume Next
'        If menuID > 0 Then
'            If I + j * 10 < img.ListImages.Count Then
'                X = SetMenuItemBitmaps(hMenu, menuID, &H4, img.ListImages(I + j * 10).Picture, img.ListImages(I + j * 10).Picture)
'            Else
'                X = SetMenuItemBitmaps(hMenu, menuID, &H4, img.ListImages(I + j * 10).Picture, img.ListImages(I + j * 10).Picture)
'            End If
'        End If
'    Next I
'  Next j
  
  
    
End Sub

Private Sub MDIForm_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    If MsgBox("确定要退出系统吗？", vbQuestion + vbYesNo, "提示窗口") = vbYes Then
        Cancel = 0
    Else
        Cancel = 1
    End If
End Sub


Private Sub MDIForm_Unload(Cancel As Integer)
    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
End Sub


Private Sub mnRecStore_Click()
    frmRecStore.Show 1
End Sub

Private Sub mnStatusBar_Click()
    mnStatusBar.Checked = Not mnStatusBar.Checked
    sbStatusBar.Visible = CBool(mnStatusBar.Checked)
End Sub

Private Sub mnToolBar_Click()
    mnToolBar.Checked = Not mnToolBar.Checked
    tbToolBar.Visible = CBool(mnToolBar.Checked)
End Sub

Private Sub mn保存库存初始数据_Click()
    frmSaveStartStore.Show 1
End Sub

Private Sub mn报表管理_Click()
    Dim msg
    msg = "报表管理是集中管理各种报表及处理各种复杂查询的地方。请参见全能查询器。"
    MsgBox msg, vbInformation, "提示信息"
End Sub

Private Sub mn编辑商品编码_Click()
    frmEditGoods.Show
End Sub

Private Sub mn编辑商品类别_Click()
    frmEditGoodsType.Show
End Sub

Private Sub mn厂家编码维护_Click()
'    frm厂家编码维护.Show
    frm厂商主档.Show
End Sub

Private Sub mn尺寸维护_Click()
    frmSize.Show
End Sub


Private Sub mn冲减库存_Click()
    frm冲减库存.Show 1
End Sub

Private Sub mn调拨单_Click()
    frmDB.Show
End Sub

Private Sub mn订单_Click()
    frmDHD.Show
End Sub

Private Sub mn订单查询_Click()
    frmQueryDD.Show
End Sub

Private Sub mn分店编码_Click()
'    frm分店编码维护.Show
    frm分店主档.Show
End Sub

Private Sub mn分店库存比较_Click()
    frmChainStore.Show
End Sub

Private Sub mn分店库存初始化_Click()
    frm分店库存初始化.Show 1
End Sub

Private Sub mn分店配送比较_Click()
    frmChainPS.Show
End Sub

Private Sub mn分店商品盘点单_Click()
    frmChainPDD.Show
End Sub

Private Sub mn分店销售_Click()
    frm分店销售单.Show
End Sub

Private Sub mn分店销售比较_Click()
    frmChainSale.Show
End Sub

Private Sub mn分店销售查询_Click()
    frmQueryChainSale.Show
End Sub

Private Sub mn付款方式_Click()
    frmPayType.Show
End Sub

Private Sub mn进货查询_Click()
    frmQueryInStore.Show
End Sub

Private Sub mn进销存明细账_Click()
    frmInOutStore.Show
End Sub

Private Sub mn经销进货_Click()
    frmJHD.Show
End Sub

Private Sub mn经营公司库存查询_Click()
    frmQueryStore.Show
End Sub

Private Sub mn经营公司销售_Click()
    frmXSD.Show
End Sub


Private Sub mn客户维护_Click()
    frmClient.Show
End Sub

Private Sub mn口令维护_Click()
    frm用户口令维护.Show 1
End Sub

Private Sub mn库存数据校验_Click()
    frmCheckStore.Show 1
End Sub

Private Sub mn连锁店订单查询_Click()
    frmQueryChainDD.Show
End Sub

Private Sub mn连锁店库存查询_Click()
    frmQueryChainStore.Show
End Sub

Private Sub mn码段维护_Click()
    frmMSize.Show 1
End Sub


Private Sub mn配比维护_Click()
    frmPB.Show
End Sub

Private Sub mn配送查询_Click()
    frmQueryPS.Show
End Sub

Private Sub mn配送单_Click()
    frmLSPSD.Show
End Sub


Private Sub mn配送单批量打印_Click()
    frmPSPrint.Show
End Sub

Private Sub mn清空数据_Click()
    frmClearData.Show 1
End Sub

Private Sub mn日志维护_Click()
    frm日志维护.Show 1
End Sub

Private Sub mn商品编码_Click()
    frm商品编码.Show
End Sub


Private Sub mn商品编码查询_Click()
    frmQueryGoods.Show
End Sub

Private Sub mn商品分类维护_Click()
    frm商品分类维护.Show
End Sub

Private Sub mn商品类别_Click()
    frmGoodsType.Show
End Sub

Private Sub mn商品盘点单_Click()
    frmPDD.Show
End Sub

Private Sub mn商品颜色及尺寸信息_Click()
    frmColorAndSize.Show
End Sub

Private Sub mn商品账页_Click()
    frmLS.Show
End Sub

Private Sub mn设置打印机_Click()
    dlgMain.ShowPrinter
End Sub

Private Sub mn设置开发票标志_Click()
    frmFP.Show 1
End Sub

Private Sub mn设置商品标志_Click()
    frmSetGoodsFlag.Show
End Sub

Private Sub mn售价调整单_Click()
    frmAdjPrice.Show
End Sub

Private Sub mn数据备份与恢复_Click()
    frmBackupAndRestore.Show 1
End Sub

Private Sub mn数据传输FTP_Click()
    frm通讯FTP.Show 1
End Sub


Private Sub mn数据检查与维护_Click()
    frmCheckGoods.Show
End Sub

Private Sub mn数据接收_Click()
    frm数据接收.Show 1
End Sub

Private Sub mn系统信息设置_Click()
    frmSystemSet.Show 1
End Sub

Private Sub mn销售查询_Click()
    frmQueryXS.Show
End Sub

Private Sub mn颜色更新_Click()
    frmChangeColor.Show
End Sub

Private Sub mn颜色维护_Click()
    frmColor.Show
End Sub

Private Sub mn用户管理_Click()
    frmUserManager.Show 1
End Sub


Private Sub mn重新登录_Click()
    frmLogin.Show 1
End Sub

Private Sub tbToolBar_ButtonClick(ByVal Button As MSComctlLib.Button)
    On Error Resume Next
    Select Case Button.Key
        Case "商品编码"
            Call mn商品编码_Click
        Case "经销进货"
            Call mn经销进货_Click
        Case "销售"
            Call mn经营公司销售_Click
        Case "配送"
            Call mn配送单_Click
        Case "重新登录"
            Call mn重新登录_Click
        Case "退出"
            Call mnuFileExit_Click
    End Select
End Sub

Private Sub mnuHelpAbout_Click()
    frmAbout.Show vbModal, Me
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 mnuFileExit_Click()
    Unload Me
End Sub