frmset.frm

超经典的打印预览动态库源码 版权： 本资源版权归作者所有 说明： 本资源由源码天空搜集,仅提供学习参考

'*作者：chlf78
'*日期：2002-04-19 11:19:19
'***************************************************************
Private Sub ShowContent()

    On Error Resume Next
    
    picContent.Cls
    rpt.ColHeader.PrintIt picContent, cpContent, 0, 0, 1
    rpt.Content.PrintIt picContent, 1, cpContent, 0, rpt.ColHeader.GetHeight, 1
    
    '*滚动条
    '*横向的处理
Dim aWidth      As Single
Dim uWidth      As Single
    
    
    '*页的宽度
    aWidth = rpt.ColHeader.GetWidth(cpContent)
    uWidth = picContent.width
    
    '*300作为一个大的change，而一个小的change为10
    If aWidth <= uWidth Then
        HContent.Max = 0
    Else
        If CLng((aWidth - uWidth) / 10) <> (aWidth - uWidth) / 10 Then
            HContent.Max = CLng((aWidth - uWidth) / 10 + 0.499999999)
        Else
            HContent.Max = (aWidth - uWidth) / 10
        End If
    End If
    
    HContent.SmallChange = 10
    HContent.LargeChange = 300
    HContent.Value = 0
End Sub


'**************************************************************
'*名称：SavePageInfo
'*功能：保存页面信息，并重新分页
'*传入参数：
'*
'*作者：chlf78
'*日期：2002-04-19 16:30:15
'***************************************************************
Private Sub SavePageInfo()

    rpt.SetPrinter txtWidth.text * UNIT, txtHeight.text * UNIT, cmbOrient.ListIndex + 1
    
    rpt.SetMargin txtLeftMargin.text * UNIT, txtTopMargin.text * UNIT, txtRightMargin.text * UNIT, txtBottomMargin.text * UNIT
    
    Me.Enabled = False
    prg.Visible = True
    rpt.CalPage
    Me.Enabled = True
    prg.Visible = False
    
    If rpt.TemplateFile <> "" Then
        rpt.SaveTemplate rpt.TemplateFile
    End If
End Sub


'**************************************************************
'*名称：LoadPageInfo
'*功能：装载页面信息
'*传入参数：
'*
'*作者：chlf78
'*日期：2002-04-19 17:08:51
'***************************************************************
Private Sub LoadPageInfo()
    With rpt
    
        txtWidth.text = .width / UNIT
        txtHeight.text = .height / UNIT
        cmbOrient.text = cmbOrient.List(.orient - 1)
        cmbOrient.tag = cmbOrient.text
        
        cmbPageAlign.text = cmbPageAlign.List(rpt.Align)

        
        txtTopMargin.text = .TopMargin / UNIT
        txtLeftMargin.text = .LeftMargin / UNIT
        txtBottomMargin.text = .BottomMargin / UNIT
        txtRightMargin.text = .RightMargin / UNIT
        
        '*处理文本
        InitText txtWidth, 1
        InitText txtHeight, 1
        InitText txtTopMargin, 1
        InitText txtLeftMargin, 1
        InitText txtBottomMargin, 1
        InitText txtRightMargin, 1
        
        
    End With
End Sub




'**************************************************************
'*名称：LoadCollection
'*功能：装载标签集合信息到控件
'*传入参数：
'*      obj             --标签集合对象
'*作者：chlf78
'*日期：2002-04-19 17:02:37
'***************************************************************
Private Sub LoadCollection(obj As clsCollection, orient As typeOrient)
Dim cText
Dim i           As Integer
Dim itmX        As MSComctlLib.ListItem

        On Error Resume Next
        
        lvCollection.ListItems.Clear

        For Each cText In obj.texts.Items
            With cText
                Set itmX = lvCollection.ListItems.Add(, .tag, .stringX)
                itmX.ForeColor = .ForeColor
                Select Case .Align
                    Case tyLeft
                        If orient = Landscape Then
                            itmX.SubItems(1) = "左"
                        Else
                            itmX.SubItems(1) = "顶"
                        End If
                    Case tymiddle
                        itmX.SubItems(1) = "中"
                    Case tyRight
                        If orient = Landscape Then
                            itmX.SubItems(1) = "右"
                        Else
                            itmX.SubItems(1) = "底"
                        End If
                End Select
                itmX.SubItems(2) = .FontName & "(" & .fontsize & ")"
                    
                .orient = orient

            End With
        Next
    
        '*对齐方式
        cmbCollectionAlign.text = cmbCollectionAlign.List(obj.AlignMode)
End Sub


'**************************************************************
'*名称：LoadContent
'*功能：装载正文列信息到控件
'*传入参数：
'*
'*作者：chlf78
'*日期：2002-04-19 17:02:37
'***************************************************************
Private Sub LoadContent()
Dim cText
Dim i           As Integer
Dim itmX        As MSComctlLib.ListItem

        On Error Resume Next

        lvContent.ListItems.Clear

        For i = 1 To rpt.ColHeader.Cols
            Set cText = rpt.Content.GetColText(i)
            With cText
                Set itmX = lvContent.ListItems.Add(, , rpt.ColHeader.GetText(i, 1).stringX)
                itmX.ForeColor = .ForeColor
                Select Case .Align
                    Case tyLeft
                        itmX.SubItems(1) = "左"
                    Case tymiddle
                        itmX.SubItems(1) = "中"
                    Case tyRight
                        itmX.SubItems(1) = "右"
                End Select
                itmX.SubItems(2) = IIf(rpt.Content.GetMergeCol(i), "是", "否")
            End With
        Next i
        '*将第一列装载
        If rpt.ColHeader.Cols > 0 Then
            Call lvContent_ItemClick(lvContent.ListItems(1))
        End If
End Sub


'**************************************************************
'*名称：LoadTemplate
'*功能：
'*传入参数：
'*
'*作者：chlf78
'*日期：2002-04-19 21:30:41
'***************************************************************
Private Sub LoadTemplate()
    If rpt.TemplateFile <> "" Then
        labtemplatefile.Caption = rpt.TemplateFile
    Else
        labtemplatefile.Caption = "无"
    End If
    
End Sub



Private Sub txtBottomMargin_GotFocus()
    SelAllTxt txtBottomMargin
End Sub

Private Sub txtBottomMargin_Validate(Cancel As Boolean)
    bDirty = bDirty Or fmtTxtData(txtBottomMargin, 1, CInt(txtHeight.text) - CInt(txtTopMargin.text), 0)
End Sub

Private Sub txtHeight_GotFocus()
    SelAllTxt txtHeight
End Sub

Private Sub txtHeight_Validate(Cancel As Boolean)
    bDirty = bDirty Or fmtTxtData(txtHeight, 1, 2000, _
                        CInt(txtLeftMargin.text) + CInt(txtRightMargin.text) + 10)
End Sub

Private Sub txtLeftMargin_GotFocus()
    SelAllTxt txtLeftMargin
End Sub

Private Sub txtLeftMargin_Validate(Cancel As Boolean)
    bDirty = bDirty Or fmtTxtData(txtLeftMargin, 1, CInt(txtWidth.text) - CInt(txtRightMargin.text), 0)
End Sub

Private Sub txtRightMargin_GotFocus()
    SelAllTxt txtRightMargin
End Sub

Private Sub txtRightMargin_Validate(Cancel As Boolean)
    bDirty = bDirty Or fmtTxtData(txtRightMargin, 1, CInt(txtWidth.text) - CInt(txtLeftMargin.text), 0)
End Sub

Private Sub txtTopMargin_GotFocus()
    SelAllTxt txtTopMargin
End Sub

Private Sub txtTopMargin_Validate(Cancel As Boolean)
    bDirty = bDirty Or fmtTxtData(txtTopMargin, 1, CInt(txtHeight.text) - CInt(txtBottomMargin.text), 0)
End Sub

Private Sub txtWidth_GotFocus()
    SelAllTxt txtWidth
End Sub

Private Sub txtWidth_Validate(Cancel As Boolean)
    bDirty = bDirty Or fmtTxtData(txtWidth, 1, 2000, _
                            CInt(txtLeftMargin.text) + CInt(txtRightMargin.text) + 10)
End Sub


'**************************************************************
'*名称：AddText
'*功能：增加一个clsText到标签集合
'*传入参数：
'*      obj         --标签集合对象
'*作者：chlf78
'*日期：2002-04-19 17:21:36
'***************************************************************
Private Sub AddText(obj As clsCollection)

    Dim fText       As New frmText
    Dim cText       As New clsText
    Dim key         As String
    
    With fText
        Set .cText = cText
        .bEditStringX = True
        .bEditHeight = True
        .bEditRowHeight = True
        .bEditWidth = True
        .Show vbModal, Me
        
        If .bSelect Then
            key = "n" & obj.texts.Count + 1
            obj.AddText key, cText
        End If
    End With
    Set fText = Nothing
    Set cText = Nothing
    
End Sub




'**************************************************************
'*名称：EditText
'*功能：编辑标签集合中的一个clsText
'*传入参数：
'*      obj         --标签集合对象
'*作者：chlf78
'*日期：2002-04-19 17:24:52
'***************************************************************
Private Sub EditText(obj As clsCollection)

    If lvCollection.SelectedItem Is Nothing Then
        Exit Sub
    End If
    
    Dim fText       As New frmText
    With fText
        Set .cText = obj.GetText(lvCollection.SelectedItem.key)
        .bEditStringX = True
        .bEditHeight = True
        .bEditRowHeight = True
        .bEditWidth = True
        .Show vbModal, Me
    End With
    Set fText = Nothing
    
End Sub


'**************************************************************
'*名称：DelText
'*功能：从标签集合中删除一个clsText
'*传入参数：
'*      obj         --标签集合对象
'*作者：chlf78
'*日期：2002-04-19 17:26:00
'***************************************************************
Private Sub DelText(obj As clsCollection)

    If lvCollection.SelectedItem Is Nothing Then
        Exit Sub
    End If
    If MsgBox("你是否要删除此项？", vbExclamation + vbYesNo, Caption) = vbYes Then
        obj.RemoveText lvCollection.SelectedItem.key
    End If
    
End Sub




'**************************************************************
'*名称：SaveCurSet
'*功能：用临时文件暂存当前设置，以备于取消设置时进行恢复
'*传入参数：
'*
'*作者：chlf78
'*日期：2002-04-29 19:31:45
'***************************************************************
Private Sub SaveCurSet()

    '*删除已经存在的临时文件
    Dim tmpStr      As String
    Dim num         As Integer
    Dim Max         As Integer
    tmpStr = Dir(App.Path & "\")
    On Error Resume Next
    num = 0
    Do While tmpStr <> ""
        If InStr(1, tmpStr, "backup", vbTextCompare) <> 0 Then
            Kill tmpStr
            num = CInt(Right(tmpStr, Len(tmpStr) - Len(App.Path) + 7))
            If num > Max Then
                Max = num
            End If
        End If
        tmpStr = Dir
    Loop
    
    On Error GoTo 0
    '*创建不重复的临时文件
    bakFile = App.Path & "\backup" & Max + 1 & ".tmp"
    
    '*将当前配置保存到临时文件
    rpt.SaveTemplate bakFile
    
    '*防止另外的程序将此配置文件删除，打开
    fn = FreeFile()
    Open bakFile For Append Lock Write As #fn
    
End Sub