mprint.bas

来自「这个是我以前做的一个客户管理系统.包内已经含有源码和所用到的控件.代码是用VB写」· BAS 代码 · 共 334 行

Attribute VB_Name = "mPrint"
Option Explicit

'定义页边距
Public Type defPageMarginType
    
    MarginTop       As Integer
    MarginBottom    As Integer
    Marginleft      As Integer
    MarginRight     As Integer
    HeaderSep       As Integer
    
End Type

Public gMargin          As defPageMarginType
Public gPaperType       As Integer


'数据来源
'Public Enum DefDataSourceType
 '   abLvw = 1       'ListView
 '   abVsf = 2       'vsFlexGrid
 '   abDB = 3        'Database
'End Enum

Public Cn                   As ADODB.Connection

Public gDataSourceType      As DataSourceType ' DefDataSourceType    '数据来源类型
Public glvwItemData         As ListView
Public gvsfItemData         As VSFlexGrid
Public gRs                  As New ADODB.Recordset

Public gFormatfields    As String       '字段格式
Public gFontSize        As String       '字体大小

'*********************廖红飞 2001.11.29 用于设置打印字体**************
Public gFontNameTitle   As String       '主标题字体名称
Public gFontSizeTitle    As Integer     '主标题字体大小
Public gbFontItalicTitle As Boolean     '主标题是否斜体
Public gbFontUnderTitle As Boolean      '主标题是否带下划线
Public gbFontBoldTitle  As Boolean      '主标题是否粗体

'陈秋林2002.4.1----------------------------------------------------------------------
Public gFontNameMuliTitle       As String       '设置子标题的字体名称
Public gFontSizeMuliTitle       As Integer      '设置子标题的字体大小
Public gbFontItalicMuliTitle    As Boolean      '设置子标题的字体是否斜体
Public gbFontUnderMuliTitle     As Boolean      '设置子标题的字体是否带下划线
Public gbFontBoldMuliTitle      As Boolean      '设置子标题的字体是否粗体

Public gFontNameFootTitle       As String       '设置尾注的字体名称
Public gFontSizeFootTitle       As Integer      '设置尾注的字体大小
Public gbFontItalicFootTitle    As Boolean      '设置尾注的字体是否斜体
Public gbFontUnderFootTitle     As Boolean      '设置尾注的字体是否带下划线
Public gbFontBoldFootTitle      As Boolean      '设置尾注的字体是否粗体
'------------------------------------------------------------------------------------


Public gFontNameHead    As String       '字段名字体名称
Public gFontSizeHead    As Integer      '字段名字体大小
Public gbFontItalicHead As Boolean      '字段名是否斜体
Public gbFontUnderHead  As Boolean      '字段名是否带下划线
Public gbFontBoldHead   As Boolean      '字段名是否粗体

Public gFontNameCon     As String      '正文字体名称
Public gFontSizeCon     As Integer     '正文字体大小
Public gbFontItalicCon  As Boolean     '正文是否斜体
Public gbFontUnderCon   As Boolean     '正文是否带下划线
Public gbFontBoldCon    As Boolean     '正文是否粗体

Public gLeftHead        As Integer      '字段名单元格左边距
Public gTopHead         As Integer      '字段名单元格上边距
Public gLeftCon         As Integer      '正文单元格左边距
Public gTopCon          As Integer      '正文单元格上边距

'********************************************************************

Public gTitle           As String       '主标题

Public gSubTitle        As String       '子标题
Public gMidTitle        As String       '日期标题
Public gLeftTitle       As String       '左上角大标题

Public gLeftTop         As String       '左上角标题
Public gMidTop          As String       '中间标题
Public gRightTop        As String       '右上角标题

Public gLeftBottom      As String       '左下角尾注
Public gMidBottom       As String       '中下尾注
Public gRightBottom     As String       '右下尾注
Public gMemoBottom      As String       '右下备注

Public gPaperDirect     As DefPaperDirect

Public gMuliHeaders     As String       '多行标题时

Public gPrintStyle      As DefPrintStyle

Public gTagInfo         As String

Public gTitleSep        As Double           '标题同正文之间的距离
Public gHeadHeight      As Double           '字段标题的高度
Public gRowHeight       As Double           '行高度
Public gPaperSize       As Integer          '纸张类型


'陈秋林5/22/02
Public gAlignment       As Integer          '对齐方式 1.左对齐 2.居中对齐


'*********************消息常量****************************
Public Const WM_KEY = 119               '消息类型
Public Const WM_KEYDOWN = &H100
Public Const WM_KEYUP = &H101
Public Const VK_LEFT = &H25
Public Const VK_DOWN = &H28
Public Const VK_UP = &H26
Public Const VK_RIGHT = &H27
Public Const WM_ACTIVATE = &H6
Public Const VK_F5 = &H74
Public Const VK_F8 = &H77

'**************************************************
'发送消息函数
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" ( _
    ByVal hwnd As Long, _
    ByVal wMsg As Long, _
    ByVal wParam As Long, _
    lParam As Any) As Long

'读取文件中内容
Public Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" ( _
    ByVal lpApplicationName As String, _
    ByVal lpKeyName As Any, _
    ByVal lpDefault As String, _
    ByVal lpReturnedString As String, _
    ByVal nSize As Long, _
    ByVal lpFileName As String) As Long

'书写文件中内容
Public Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" ( _
    ByVal lpApplicationName As String, _
    ByVal lpKeyName As Any, _
    ByVal lpString As Any, _
    ByVal lpFileName As String) As Long
    
'读取Windows系统路径
Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long





Public Sub Center(frm As Variant, Optional vParent)
'
' Centralize SDI-form (gCenter Me) or MDIChild form (gCenter Me,MDIForm).
'
    On Error Resume Next
    If IsMissing(vParent) Then Set vParent = Screen
    With frm
        .Top = (vParent.Height - .Height) / 2
        .left = (vParent.Width - .Width) / 2
    End With
    
    Err.Clear
    
End Sub


Public Sub gShowMsg(Msg As String, Optional iFlag As Byte)
'**************************************************
'
'Purpose:
'       简化弹出Message box
'
'**************************************************

    If IsMissing(iFlag) Or iFlag = 0 Then
        Msg = Msg & vbCrLf & "错误代码: " & Err.Number & vbCrLf & "错误来源: " & Err.Source & vbCrLf
        MsgBox Msg & Err.Description, vbInformation, "警告"
    Else
        Msg = Msg & vbCrLf & "错误代码: " & Err.Number & vbCrLf & "错误来源: " & Err.Source & vbCrLf
        MsgBox Msg & Err.Description, vbInformation, "提示"
    End If
    
End Sub

Public Function gNumericKey(KeyAscii As Integer, Optional bPot As Boolean) As Integer
'**************************************************
'
'Purpose:
'       filter key to get Numeric key
'
'**************************************************
    
    gNumericKey = KeyAscii
    
        Select Case KeyAscii
        Case 8
            ' Backspace OK
        Case 3, 22, 24
            'Ctrl-C,Ctrl-V,Ctrl_X.
        Case 48 To 57
             ' 0 to 9 ok
        Case 46
            If IsMissing(bPot) Or bPot = False Then
                gNumericKey = 0
            Else
                gNumericKey = 46
            End If
            '.'
        Case vbKeyDecimal
        Case vbKeyReturn
        Case vbKeyEscape
        Case Else
            ' Everything else a no-no
            gNumericKey = 0
    End Select

End Function

Public Sub InitTextBox(txt As Variant)
'************************************************
'
'Select all the text string in textbox.
'
'************************************************
    On Error Resume Next
    With txt
        .SelStart = 0
        .SelLength = Len(.Text)
    End With
    
End Sub

Public Function gMMtoTwip(vMM As Integer) As Double
'********************************************************
'
'Purpose:
'       将缇单位的长度转变为mm单位长度
'
'********************************************************
    Dim tmpMM           As Double
    
    tmpMM = vMM * 56.7
    
    gMMtoTwip = tmpMM
    
    
End Function

Public Function SendMessageToCtl(Ctl As Variant, wMsg%, wParam%, lParam&)
'*************************************************************************
'
'Purpose
'       将消息发送给控件
'
'*************************************************************************
    Dim CtlHwnd         As Long
    Dim i               As Integer
    
'    Ctl.SetFocus
    CtlHwnd = Ctl.hwnd
'    CtlHwnd = GetFocus()
    i = SendMessage(CtlHwnd, wMsg%, wParam%, lParam&)
    
End Function


Public Function mGetWindowsPath() As String
'*************************************************
'
'读取Windows系统路径
'
'**************************************************
    
    Dim sLen            As Integer
    Dim tmpWin          As String * 260
    Dim WinFilePath     As String
    
    On Error GoTo ErrGetWindowsPath
    
    sLen = GetWindowsDirectory(tmpWin, 260)
    If sLen = 0 Then
        MsgBox "读取系统路径出错！！！", vbInformation + vbOKOnly, ""
        mGetWindowsPath = ""
        Screen.MousePointer = vbDefault
        Exit Function
    Else
        WinFilePath = Mid(tmpWin, 1, sLen)
    End If
    
    mGetWindowsPath = WinFilePath
    
    Exit Function
ErrGetWindowsPath:
    Screen.MousePointer = vbDefault
    mGetWindowsPath = ""
    gShowMsg "读取Windows系统路径出错 "

End Function

Public Function mGetValues(Title As String, Item As String, sFile As String) As String
'******************************************************************************************
'
'取得Ini文件中某一项内容
'
'******************************************************************************************
    Dim nLen            As Integer
    Dim tmpStr          As String * 200
    
    
    nLen = GetPrivateProfileString(Title, Item, "", tmpStr, 200, sFile)
    If nLen > 0 Then
        mGetValues = Mid(tmpStr, 1, nLen)
    Else
        mGetValues = ""
    End If

End Function

Public Function mbSaveValues(Title As String, Item As String, Values As String, sFile As String) As Boolean
'***********************************************************************************************************
'
'更改INI文件中的内容
'
'**********************************************************************************************************
    Dim bRet        As Long

    bRet = WritePrivateProfileString(Title, Item, Values, sFile)
    mbSaveValues = True
    
End Function