preview.frm

自定报表组件

  Me.Refresh
End Sub

Private Sub PrintPage(ByVal PageNo As Long)
  Dim L As Long
  Dim T As Long
  Dim W As Long
  Dim H As Long
  Dim I As Long
  Dim N As Long
  Dim CMDStartNo As Long
  Dim CMDEndNo As Long
  Dim CMDCount As Long
  Dim Processed As Single
  Dim CMD As String
  Dim Msg As String
  Dim V1 As Single
  Dim V2 As Single
  Dim V3 As Single
  Dim V4 As Single
  
  On Error Resume Next
  
  CMDStartNo = arrPreviewPage(PageNo - 1).CMDStart
  CMDEndNo = arrPreviewPage(PageNo - 1).CMDEnd
  CMDCount = CMDEndNo - CMDStartNo + 1
  
  With picProcess
    .Move (Me.Width - .Width) / 2, (Me.Height - .Height) / 2
    .Cls
    Msg = IIf(devPrinter, "正在输出打印页", "正在刷新预览页面") & PageNo & "..."
    L = RoundTo15((.Width - .TextWidth(Msg)) / 2)
    If devPrinter Then
      T = RoundTo15(.Height / 5)
    Else
      T = RoundTo15(.Height / 4)
    End If
    .CurrentX = L
    .CurrentY = T
    .ForeColor = &H808080
    picProcess.Print Msg
    .CurrentX = L - 30
    .CurrentY = T - 30
    .ForeColor = &HFFFFFF
    picProcess.Print Msg
    .CurrentX = L - 15
    .CurrentY = T - 15
    .ForeColor = 0
    picProcess.Print Msg
    L = 0
    T = 0
    W = .Width
    H = .Height
    PicBox3D picProcess, L, T, W, H, 0
    PicBox3D picProcess, L + 15, T + 15, W - 30, H - 30, 1
    PicBox3D picProcess, L + 15 * 8, T + 15 * 8, W - 30 * 8, H - 30 * 8, -1
    W = .Width - 600
    H = 240
    L = RoundTo15((.Width - W) / 2) - 15
    If devPrinter Then
      T = RoundTo15(.Height / 7 * 3)
    Else
      T = RoundTo15(.Height / 7 * 4)
    End If
    PicBox3D picProcess, L - 15, T - 15, W + 45, H + 45, -1
    .Visible = True
    If devPrinter Then
      cmdPrintCancel.Visible = True
      cmdPrintCancel.SetFocus
    Else
      cmdPrintCancel.Visible = False
    End If
    .Refresh
    Processed = 0
  End With
  For I = CMDStartNo To CMDEndNo
    V1 = (I - CMDStartNo + 1) / CMDCount
    If (V1 - Processed) * W >= 15 Then
      Processed = V1
      picProcess.Line (L, T)-Step(W * Processed, H), &HFF0000, BF
      picProcess.Refresh
      If devPrinter Then
        DoEvents
        If PrintCancel Then Exit For
      End If
    End If
    With arrPreviewCMD(I)
      CMD = Trim(.CMD)
      V1 = .V1
      V2 = .V2
      V3 = .V3
      V4 = .V4
      Msg = .Msg
    End With
    Select Case CMD
      Case "Arc"
        Arc V1, V2, V3, Msg
      Case "OutputBarCodeOf39Ex"
        OutputBarCode V1, V2, V3, V4, Msg, 0
      Case "OutputBarCodeOf25"
        OutputBarCode V1, V2, V3, V4, Msg, 1
      Case "OutputBarCodeOf128"
        OutputBarCode V1, V2, V3, V4, Msg, 2
      Case "Box"
        devPrintTo.Line (V1 * CellWidth, V2 * CellHeight)-Step(V3 * CellWidth, V4 * CellHeight), mForeColor, B
      Case "BoxLine"
        devPrintTo.Line (V1 * CellWidth, V2 * CellHeight)-Step(V3 * CellWidth, 0), mForeColor
        devPrintTo.Line -Step(0, V4 * CellHeight), mForeColor
        devPrintTo.Line -Step(-V3 * CellWidth, 0), mForeColor
        devPrintTo.Line -Step(0, -V4 * CellHeight), mForeColor
      Case "CellSize"
        CellWidth = IIf(V1 < 1, 1, V1)
        CellHeight = IIf(V2 < 1, 1, V2)
      Case "DrawMode"
        devPrintTo.DrawMode = V1
      Case "DrawStyle"
        devPrintTo.DrawStyle = V1
      Case "DrawWidth"
        If devPrinter Then
          V1 = (8 / Printer.TwipsPerPixelX) * V1 * sqrPrintScale + 0.5
        Else
          V1 = V1 * sqrPreviewScale * sqrPrintScale + 0.5
        End If
        V1 = Int(V1)
        If V1 < 1 Then V1 = 1
        devPrintTo.DrawWidth = V1
      Case "FillColor"
        devPrintTo.FillColor = V1
      Case "FillStyle"
        devPrintTo.FillStyle = V1
      Case "FontBold"
        devPrintTo.FontBold = V1
      Case "FontItalic"
        devPrintTo.FontItalic = V1
      Case "Width"
        devPrintTo.Width = gWidth
        'gaScaleWidth = V1
      Case "Height"
        devPrintTo.Height = gHeight
        'gaScaleHeight = V1
      Case "FontName"
        SetFontName Msg
      Case "FontSize"
        devPrintTo.FontSize = V1 * IIf(devPrinter, 1, sqrPreviewScale) * sqrPrintScale
      Case "FontStrikethrough"
        devPrintTo.FontStrikethrough = V1
      Case "FontTransparent"
        SetBkMode devPrintTo.hdc, IIf(V1, 1, 2)
      Case "FontUnderline"
        devPrintTo.FontUnderline = V1
      Case "ForeColor"
        devPrintTo.ForeColor = V1
        mForeColor = V1
      Case "LineH"
        devPrintTo.Line (V1 * CellWidth, V2 * CellHeight)-Step(V3 * CellWidth, 0), mForeColor
      Case "LineU"
        V4 = devPrintTo.TextHeight("T") / 2
        devPrintTo.Line (V1 * CellWidth, V2 * CellHeight + V4)-Step(V3 * CellWidth, 0), mForeColor
      Case "LineV"
        devPrintTo.Line (V1 * CellWidth, V2 * CellHeight)-Step(0, V3 * CellHeight), mForeColor
      Case "LineW"
        devPrintTo.Line (V1 * CellWidth, V2 * CellHeight)-(V3 * CellWidth, V4 * CellHeight), mForeColor
      Case "PaintPicture"
        PaintPictureStretch V1, V2, V3, V4, Msg
      Case "PointSet"
        devPrintTo.PSet (V1, V2), mForeColor
      Case "ScaleLeft"
        devPrintTo.ScaleLeft = V1 + IIf(devPrinter, IIf(Printer.Orientation = vbPRORPortrait, Offset1, Offset2), 0)
      Case "ScaleTop"
        devPrintTo.ScaleTop = V1 + IIf(devPrinter, IIf(Printer.Orientation = vbPRORPortrait, Offset3, Offset1), 0)
      Case "ShowGrid"
        ShowGrid
      Case "TextC"
        TextC V1, V2, Msg
      Case "TextE"
        TextE V1, V2, V3, Msg
      Case "TextL"
        TextL V1, V2, Msg
      Case "TextR"
        TextR V1, V2, Msg
      Case "TextVE"
        TextVE V1, V2, V3, Msg
    End Select
  Next I
  picProcess.Visible = False
End Sub

Public Sub Arc(ByVal X As Single, ByVal Y As Single, ByVal Radius As Single, ByVal Msg As String)
  'Units:Cell Size
  Const ArcPerDegree As Double = 3.14159265358979 / 180
  
  Dim StartArc As Single
  Dim EndArc As Single
  Dim Aspect As Single
  
  X = X * CellWidth
  Y = Y * CellHeight
  Radius = Radius * CellWidth
  StartArc = GetOptionalValue(Msg, 1, -777)
  If StartArc <> -777 Then StartArc = StartArc * ArcPerDegree
  EndArc = GetOptionalValue(Msg, 2, -777)
  If EndArc <> -777 Then EndArc = EndArc * ArcPerDegree
  Aspect = GetOptionalValue(Msg, 3, 1)
  
  If StartArc = -777 Then
    If EndArc = -777 Then
      devPrintTo.Circle (X, Y), Radius, mForeColor, , , Aspect
    Else
      devPrintTo.Circle (X, Y), Radius, mForeColor, , EndArc, Aspect
    End If
  Else
    If EndArc = -777 Then
      devPrintTo.Circle (X, Y), Radius, mForeColor, StartArc, , Aspect
    Else
      devPrintTo.Circle (X, Y), Radius, mForeColor, StartArc, EndArc, Aspect
    End If
  End If
End Sub

Private Sub PaintPictureStretch(ByVal L As Single, ByVal T As Single, ByVal W As Single, ByVal H As Single, ByVal FN As String)
  Dim pic As Picture
  
  On Error Resume Next
  Set pic = LoadPicture(FN)
  If Err = 0 Then
    devPrintTo.PaintPicture pic, L * CellWidth, T * CellHeight, W * CellWidth, H * CellHeight
  End If
End Sub

Private Sub ShowGrid()
  Dim W As Long
  Dim H As Long
  Dim I As Long
  Dim DW As Long
  
  With devPrintTo
    W = (.ScaleWidth + .ScaleLeft) / CellWidth
    H = (.ScaleHeight + .ScaleTop) / CellHeight
    
    DW = .DrawWidth
    .DrawWidth = 1
    For I = 0 To H
      devPrintTo.Line (0, CellHeight * I)-Step(CellWidth * W, 0), &HFF
    Next I
    For I = 0 To W
      devPrintTo.Line (CellWidth * I, 0)-Step(0, CellHeight * H), &HFF
    Next I
    devPrintTo.DrawWidth = DW
  End With
End Sub

Private Sub TextC(ByVal X As Single, ByVal Y As Single, ByVal Msg As String)
  '对中打印字串
  'X,Y 字串中心坐标
  'Msg 字串
  
  With devPrintTo
    .CurrentX = X * CellWidth - .TextWidth(Msg) / 2
    .CurrentY = Y * CellHeight - .TextHeight("T") / 2
    devPrintTo.Print Msg
  End With
End Sub

Private Sub TextE(ByVal X As Single, ByVal Y As Single, ByVal W As Single, ByVal Msg As String)
  '等间距打印字串
  'X,Y 左端中心坐标
  'W 宽度
  'Msg 字串
    
  Dim I As Long
  Dim L As Long
  Dim WordWidth As Single
  Dim Distance As Single
  
  With devPrintTo
    L = Len(Msg)
    WordWidth = .TextWidth("口") / CellWidth
    X = X + WordWidth / 2
    Y = Y - .TextHeight("T") / 2 / CellHeight
    Distance = (W - WordWidth) / (L - 1)
    For I = 1 To L
      .CurrentX = (X + Distance * (I - 1) - WordWidth / 2) * CellWidth
      .CurrentY = Y * CellHeight
      devPrintTo.Print Mid(Msg, I, 1)
    Next I
  End With
End Sub

Private Sub TextL(ByVal X As Single, ByVal Y As Single, ByVal Msg As String)
  '靠左打印字串
  'X,Y 左端中心坐标
  'Msg 字串
  
  With devPrintTo
    .CurrentX = X * CellWidth
    .CurrentY = Y * CellHeight - .TextHeight("T") / 2
    devPrintTo.Print Msg
  End With
End Sub

Private Sub TextR(ByVal X As Single, ByVal Y As Single, ByVal Msg As String)
  '靠右打印字串
  'X,Y 右端中心坐标
  'Msg 字串
  
  With devPrintTo
    .CurrentX = X * CellWidth - .TextWidth(Msg)
    .CurrentY = Y * CellHeight - .TextHeight("T") / 2
    devPrintTo.Print Msg
  End With
End Sub

Private Sub TextVE(ByVal X As Single, ByVal Y As Single, ByVal H As Single, ByVal Msg As String)
  '垂直等间距打印字串
  'X,Y 字串首中心坐标
  'H 高度(打印范围)
  'Msg 字串
  Dim I As Long
  Dim L As Long
  Dim WordHeight As Single
  Dim Distance As Single
  
  With devPrintTo
    L = Len(Msg)
    X = X - .TextWidth("口") / 2 / CellWidth
    WordHeight = .TextHeight("口") / CellHeight
    Y = Y + WordHeight / 2
    Distance = (H - WordHeight) / (L - 1)
    For I = 1 To L
      .CurrentX = X * CellWidth
      .CurrentY = (Y + Distance * (I - 1) - WordHeight / 2) * CellHeight
      devPrintTo.Print Mid(Msg, I, 1)
    Next I
  End With
End Sub

Private Function GetOptionalValue(ByVal Msg As String, ByVal No As Long, ByVal DefaultValue)
  Dim Value As String
  Dim N As Long
  
  Msg = Msg & ","
  Do While (No > 0)
    No = No - 1
    N = InStr(Msg, ",")
    If N = 0 Then
      Exit Do
    Else
      If No = 0 Then
        Value = Left(Msg, N - 1)
        Exit Do
      End If
      Msg = Mid(Msg, N + 1)
    End If
  Loop
  
  If Len(Value) = 0 Then Value = DefaultValue
  GetOptionalValue = Value
End Function

Private Sub OutputBarCode(ByVal L As Single, ByVal T As Single, ByVal W As Single, ByVal H As Single, ByVal BarCode As String, ByVal BarCodeType As Long)
  Dim I As Long
  Dim J As Long
  Dim BCW As Single
  Dim OutputBar As String
  Dim TmpCode As String
  Dim tmpCode1 As String
  Dim C As Long
  Dim LastDrawWidth As Long
  Dim CS As Long
  
  On Error Resume Next
  BarCodesOf39ExInit BarCodeType
  Select Case BarCodeType
    Case 0   '3 of 9
      For I = 1 To Len(BarCode)
        TmpCode = ""
        TmpCode = BarCodesOf39Ex(Asc(Mid(BarCode, I, 1)))
        If Len(TmpCode) >= 0 Then OutputBar = OutputBar & "0" & TmpCode  '
      Next I
      OutputBar = BarCodesBeginSign & OutputBar & "0" & BarCodesEndSign
    Case 1   '2 of 5
      OutputBar = ""
      If Len(BarCode) Mod 2 <> 0 Then BarCode = "0" & BarCode
      For I = 1 To Len(BarCode) Step 2
        TmpCode = ""
        TmpCode = BarCodesOf39Ex(Asc(Mid(BarCode, I, 1)))
        tmpCode1 = BarCodesOf39Ex(Asc(Mid(BarCode, I + 1, 1)))
        For J = 1 To Len(TmpCode)
          OutputBar = OutputBar & Mid(TmpCode, J, 1)
          OutputBar = OutputBar & Mid(tmpCode1, J, 1)
        Next J
      Next I
      OutputBar = BarCodesBeginSign & OutputBar & BarCodesEndSign
    Case 2  '128
      If Len(BarCode) Mod 2 <> 0 Then BarCode = "0" & BarCode
      TmpCode = ""
      CS = 105 + 102
      J = 1
      For I = 1 To Len(BarCode)
        If I Mod 2 <> 0 Then
          TmpCode = TmpCode & BarCodesOf39Ex(Val(Mid(BarCode, I, 2)))
          J = J + 1
          CS = CS + Val(Mid(BarCode, I, 2)) * J
        End If
      Next I
     CS = CS Mod 103
     TmpCode = BarCodesBeginSign & TmpCode & BarCodesOf39Ex(CS) & BarCodesEndSign
     OutputBar = TmpCode
     C = Len(OutputBar)
      For I = 1 To Len(OutputBar)
      '  If Mid(OutputBar, I, 1) = "1" Then C = C + 1
      Next I
      BCW = W / C
      LastDrawWidth = devPrintTo.DrawWidth
      devPrintTo.DrawWidth = 1
      For I = 1 To Len(OutputBar) + 1
        W = BCW ' + IIf(Mid(OutputBar, I, 1) = "1", BCW, 0)
        devPrintTo.Line (L, T)-Step(W, H), IIf(Mid(OutputBar, I, 1) = "1", 0, &HFFFFFF), BF
        L = L + W
      Next I
     Exit Sub
  End Select
  C = Len(OutputBar)
  For I = 1 To Len(OutputBar)
    If Mid(OutputBar, I, 1) = "1" Then C = C + 1
  Next I
  BCW = W / C
  LastDrawWidth = devPrintTo.DrawWidth
  devPrintTo.DrawWidth = 1
  For I = 1 To Len(OutputBar) + 1
    W = BCW + IIf(Mid(OutputBar, I, 1) = "1", BCW, 0)
    devPrintTo.Line (L, T)-Step(W, H), IIf(I Mod 2 = 1, 0, &HFFFFFF), BF
    L = L + W
  Next I
  devPrintTo.DrawWidth = LastDrawWidth
End Sub

Private Sub SetFontName(ByVal vFN As String)
  Dim I As Long
  Dim vFNLen As Long
  Dim OutputFN As String
  Dim Value As String
  
  For I = 0 To arrFontNameCount - 1
    If arrFontName(0, I) = vFN Then
      devPrintTo.FontName = arrFontName(1, I)
      Exit Sub
    End If
  Next I
  
  On Error Resume Next
  Printer.FontName = vFN
  If (Err = 0) And gPreviewShow Then picPreview.FontName = vFN
  If Err = 0 Then
    OutputFN = vFN
  Else
    vFNLen = Len(vFN)
    With Printer
      For I = .FontCount - 1 To 0 Step -1
        If Left(.Fonts(I), vFNLen) = vFN Then
          If gPreviewShow Then
            Err.Clear
            picPreview.FontName = .Fonts(I)
            If Err = 0 Then
              OutputFN = .Fonts(I)
              Exit For
            End If
          Else
            OutputFN = .Fonts(I)
            Exit Sub
          End If
        End If
      Next I
    End With
    If Len(OutputFN) = 0 Then OutputFN = "宋体"
  End If
  
  arrFontNameCount = arrFontNameCount + 1
  ReDim Preserve arrFontName(1, arrFontNameCount - 1)
  arrFontName(0, arrFontNameCount - 1) = vFN
  arrFontName(1, arrFontNameCount - 1) = OutputFN
  devPrintTo.FontName = OutputFN
End Sub