frmmain.frm

mschart制作各种图表的范例,适合各位刚学VB的学者

    v = pbcolMonthlyData(pbasMonth(l))
    li.SubItems(1) = v(0)
    li.SubItems(2) = v(1)
    li.SubItems(3) = v(2)
    li.Checked = True
Next
End Sub

'将列表中的数据填充到集合
Sub ListToCollection()
On Error Resume Next
Dim v As Variant, li As ListItem, a(2) As Single, l As Long, i As Long
For l = 0 To 11
    Set li = lvData.ListItems(pbasMonth(l))
    For i = 0 To 2
        pbcolMonthlyData(pbasMonth(l))(i) = CSng(li.SubItems(i + 1))
    Next
Next
End Sub

'获得导入数据文件名
Function GetOpenFile(ByRef s As String) As Boolean
On Error GoTo staErr

With frmMain.cdlg
    .CancelError = True
    .InitDir = App.Path
    .Flags = cdlOFNExplorer Or _
                cdlOFNLongNames Or _
                    cdlOFNHideReadOnly
    .Filter = "数据文件(*.dia)|*.dia"
    .ShowOpen
    s = Trim(.FileName)
End With
    
GetOpenFile = True
Exit Function
staErr:
GetOpenFile = False
End Function
'获得保存文件名
Function GetSaveFile(ByRef s As String) As Boolean
On Error GoTo staErr

With frmMain.cdlg
    .CancelError = True
    .InitDir = App.Path
    .Flags = cdlOFNExplorer Or _
                cdlOFNLongNames Or _
                    cdlOFNHideReadOnly Or _
                        cdlOFNOverwritePrompt
    .Filter = "数据文件(*.dia)|*.dia"
    .FileName = s
    .ShowSave
    s = Trim(.FileName)
End With
    
GetSaveFile = True
Exit Function
staErr:
GetSaveFile = False
End Function

Function CheckButtonStat()
On Error Resume Next
If pbfInit = True Then
    pbfEditMode = False
    cmdSave.Enabled = False
    cmdModify.Caption = "添加数据"
    cmdModify.Tag = "1"
Else
    pbfEditMode = True
    cmdSave.Enabled = True
    cmdModify.Caption = "修改数据"
    cmdModify.Tag = "0"
End If
SetLabelText
End Function
Sub SetLabelText()
lbl(1) = cmdGenerateDiagram.Caption
lbl(2) = cmdModify.Caption
lbl(3) = cmdClear.Caption
lbl(4) = cmdLoad.Caption
lbl(5) = cmdSave.Caption
lbl(6) = cmdExit.Caption
End Sub
Sub SetRegion()
Dim hFinal As Long, hBar As Long, hCentre As Long, hBall(5) As Long, l As Long, lr As Long, lOld As Long

lOld = frmMain.ScaleMode
frmMain.ScaleMode = vbPixels

hFinal = CreateRectRgn(0, 0, Me.ScaleWidth, Me.ScaleHeight)

With pbs
    hBar = CreateRectRgn(.Left + lOffsetX - 6, .Top + lOffsetY + 1 - 4, .Left + .Width + 4, .Top + .Height + 4)
    'hBar = CreateRoundRectRgn(.Left + lOffsetX, .Top + lOffsetY + 1, .Left + .Width, .Top + .Height, 20, 20)
    'hBar = CreateEllipticRgn(.Left + lOffsetX - 5, .Top + lOffsetY + 1 - 5, .Left + .Width + 5, .Top + .Height + 5)
End With

With lvData
    hCentre = CreateRectRgn(.Left + lOffsetX - 6, .Top + lOffsetY + 1 - 4, .Left + .Width + 4, .Top + .Height + 4)
    'hCentre = CreateRoundRectRgn(.Left + lOffsetX, .Top + lOffsetY + 1, .Left + .Width, .Top + .Height - 15, 10, 10)
End With


For l = 0 To 5
    With pb(l)
        lr = l * 2.5 - 1
        hBall(l) = CreateEllipticRgn(.Left + lOffsetX + lr, .Top + lOffsetY + lr, .Left + .Width - lr, .Top + .Height - lr)
    End With
Next

Call CombineRgn(hFinal, hBar, hCentre, RGN_OR)
Call CombineRgn(hFinal, hFinal, hBall(0), RGN_OR)

'Call CombineRgn(hFinal, hCentre, hBall(0), RGN_OR)

Call CombineRgn(hFinal, hFinal, hBall(1), RGN_OR)
Call CombineRgn(hFinal, hFinal, hBall(2), RGN_OR)
Call CombineRgn(hFinal, hFinal, hBall(3), RGN_OR)
Call CombineRgn(hFinal, hFinal, hBall(4), RGN_OR)
Call CombineRgn(hFinal, hFinal, hBall(5), RGN_OR)


Call SetWindowRgn(Me.hwnd, hFinal, True)

frmMain.ScaleMode = lOld
End Sub
'******************************************************
'*窗体函数
'******************************************************


Private Sub cmdClear_Click()
If pbfInit = False Then
    If MsgBox("您确定要清除列表框吗?", vbYesNo + vbDefaultButton2 + vbQuestion) = vbYes Then
        LVinit
        pbfEditMode = False
    End If
End If
End Sub

Private Sub cmdExit_Click()
Unload Me
End Sub

Private Sub cmdGenerateDiagram_Click()

frmWizard.Show vbModal
End Sub

Private Sub cmdLoad_Click()
Dim sPath As String
sPath = pbsDataFileName
If GetOpenFile(sPath) Then
    If LoadData(sPath, pbcolMonthlyData) Then
        pbsDataFileName = sPath
        lvData.Enabled = True
        CollectionToList
        pbfInit = False
        MsgBox "数据已成功从文件 " + """" + pbsDataFileName + """" + " 导入。", vbOKOnly + vbInformation, "数据导入"
    End If
End If
CheckButtonStat
End Sub

Private Sub cmdModify_Click()
frmData.Show vbModal
CheckButtonStat
End Sub

Private Sub cmdSave_Click()
Dim sPath As String
ListToCollection
sPath = pbsDataFileName

If GetSaveFile(sPath) Then
    If SaveData(sPath, pbcolMonthlyData) Then
        MsgBox "数据已保存到 " + sPath, vbOKOnly + vbInformation
    Else
        MsgBox "数据未保存到 " + sPath, vbOKOnly + vbInformation
    End If
End If
End Sub




Private Sub Form_Load()
If App.PrevInstance = True Then End

InitProc

SetRegion


End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
Dim v As Variant
For Each v In pb
    If v.Tag = "1" Then v.Picture = imgbtn(0).Picture
Next
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
If MsgBox("您真的想退出么？", vbYesNo + vbDefaultButton2 + vbQuestion) = vbYes Then
    SavePath
    Set pbcolMonthlyData = Nothing
    Unload frmData
    Unload frmWizard
    Unload frmDiagram
Else
    Cancel = True
End If
End Sub

Private Sub img_Click(Index As Integer)
Select Case Index
Case 0
    cmdGenerateDiagram_Click
Case 1
    cmdModify_Click
Case 2
    cmdClear_Click
Case 3
    cmdLoad_Click
Case 4
    cmdSave_Click
Case 5
    cmdExit_Click
Case 6
End Select
End Sub

Private Sub img_MouseMove(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
img(Index).Picture = imgbtn(1).Picture
End Sub

Private Sub lbl_Click(Index As Integer)
img_Click Index - 1
End Sub

Private Sub lbl_MouseDown(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
pb_MouseDown Index - 1, Button, Shift, x, y
End Sub

Private Sub lbl_MouseMove(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
pb_MouseMove Index - 1, Button, Shift, x, y
End Sub

Private Sub lbl_MouseUp(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
pb_MouseUp Index - 1, Button, Shift, x, y

End Sub

Private Sub lvData_DblClick()
lvData.SelectedItem.Checked = Not lvData.SelectedItem.Checked

End Sub


Private Sub lvData_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
Dim s As String, li As ListItem
With pb(lLastID)
    If .Tag = "1" Then
        .Picture = imgbtn(0).Picture
        .Tag = "0"
    End If
End With

With lvData
    Set li = .HitTest(x, y)
    s = "月份：" + li.Text + _
            "  计划数据：" + li.SubItems(1) + pbsDataUnit + _
                "  实际数据：" + li.SubItems(2) + pbsDataUnit + _
                    "  预测数据：" + li.SubItems(3) + pbsDataUnit
    .ToolTipText = s
End With
End Sub


Private Sub pb_Click(Index As Integer)
img_Click Index
End Sub

Private Sub pb_MouseDown(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
pb(Index).Picture = imgbtn(2).Picture
End Sub

Private Sub pb_MouseMove(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
Static i As Integer
pb(Index).Picture = imgbtn(1).Picture
pb(Index).Tag = "1"
If i <> Index Then
    pb(i).Picture = imgbtn(0).Picture
    pb(i).Tag = "0"
End If
i = Index
lLastID = i
End Sub

Private Sub pb_MouseUp(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
pb(Index).Picture = imgbtn(1).Picture
End Sub

Private Sub pbs_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
SetCapture pbs.hwnd
fMouseStat = True
lX = x
lY = y

End Sub


Private Sub pbs_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
Dim l As Long
If fMouseStat Then
    With frmMain
        l = .ScaleMode
        .ScaleMode = vbTwips
        .Move .Left + (x - lX), .Top + (y - lY)
        lX = x
        lY = y
        .ScaleMode = l
    End With
End If
ReleaseCapture
fMouseStat = False

End Sub

Private Sub tmr_Timer()
On Error Resume Next
If pbfInit = True Then
    pbfEditMode = False
    cmdSave.Enabled = False
    cmdModify.Caption = "添加数据(&A)"
    cmdModify.Tag = "1"
Else
    pbfEditMode = True
    cmdSave.Enabled = True
    cmdModify.Caption = "修改数据(&M)"
    cmdModify.Tag = "0"
End If
End Sub

Private Sub txtFilepath_Change()
pbsDataFileName = Trim(txtFilepath.Text)
End Sub