special128.bas

条形码的设计与打印

Attribute VB_Name = "Special128"
'本模块用于生成128型条码
Public Const LF_FACESIZE = 30
Global str3 As String
Global bld%, itl%, strk%, und%, j%, sp%
Global bar As BBAR_INFO
Global RetVal As RET_VAL
Dim Dl As Long, Th As Long
Dim textdisp As String
Type POINTAPI
        x As Long
        y As Long
End Type
Type LOGFONT
        lfHeight As Long
        lfWidth As Long
        lfEscapement As Long
        lfOrientation As Long
        lfWeight As Long
        lfItalic As Byte
        lfUnderline As Byte
        lfStrikeOut As Byte
        lfCharSet As Byte
        lfOutPrecision As Byte
        lfClipPrecision As Byte
        lfQuality As Byte
        lfPitchAndFamily As Byte
        lfFaceName(LF_FACESIZE) As Byte
End Type
Type Size
        cx As Long
        cy As Long
End Type
Type TEXTMETRIC
        tmHeight As Long
        tmAscent As Long
        tmDescent As Long
        tmInternalLeading As Long
        tmExternalLeading As Long
        tmAveCharWidth As Long
        tmMaxCharWidth As Long
        tmWeight As Long
        tmOverhang As Long
        tmDigitizedAspectX As Long
        tmDigitizedAspectY As Long
        tmFirstChar As Byte
        tmLastChar As Byte
        tmDefaultChar As Byte
        tmBreakChar As Byte
        tmItalic As Byte
        tmUnderlined As Byte
        tmStruckOut As Byte
        tmPitchAndFamily As Byte
        tmCharSet As Byte
End Type
Public Type MEMORYSTATUS
        dwLength As Long
        dwMemoryLoad As Long
        dwTotalPhys As Long
        dwAvailPhys As Long
        dwTotalPageFile As Long
        dwAvailPageFile As Long
        dwTotalVirtual As Long
        dwAvailVirtual As Long
End Type
Type BBAR_INFO
    szReadText As String
    szAdDigit As String
    szDigit As String
    szBarCaption As String
    tiFaceName As String
    szSymbology As Long
    lalign As Long
    ltxtdisp As Long
    nsize As Long
    lstyle As Long
    lheight As Long
    lLeft As Long
    lTop As Long
    lWidth As Long
    lExtra As Long
    lR1 As Long
    lR2 As Long
    lRetWidth As Long
    lRetHeight As Long
    lRotation As Long
    crFore As Long
    crBack As Long
    TextColor As Long
    lShowCheck As Long
End Type
Type RET_VAL
     lnRtheight As Long
     lnRtWidth As Long
End Type
Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type

Declare Function SetRect Lib "user32" (lpRect As RECT, _
                                    ByVal X1 As Long, _
                                    ByVal Y1 As Long, _
                                    ByVal X2 As Long, _
                                    ByVal Y2 As Long) As Long
Declare Function SetTextCharacterExtra Lib "gdi32" ( _
                                    ByVal hDc As Long, _
                                    ByVal nCharExtra As Long) As Long
Declare Function DeleteObject Lib "gdi32" ( _
                                    ByVal hObject As Long) As Long
Declare Function GetTextMetrics Lib "gdi32" _
                                    Alias "GetTextMetricsA" ( _
                                    ByVal hDc As Long, _
                                    lpMetrics As TEXTMETRIC) As Long
Declare Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As Long
Declare Function SelectObject Lib "gdi32" ( _
                                    ByVal hDc As Long, _
                                    ByVal hObject As Long) As Long
Declare Function GetDeviceCaps Lib "gdi32" ( _
                                    ByVal hDc As Long, _
                                    ByVal nIndex As Long) As Long
Declare Function GetTextExtentPoint32 Lib "gdi32" _
                                    Alias "GetTextExtentPoint32A" ( _
                                    ByVal hDc As Long, _
                                    ByVal lpsz As String, _
                                    ByVal cbString As Long, _
                                    lpSize As Size) As Long
Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, _
                                    ByVal nNumerator As Long, _
                                    ByVal nDenominator As Long) As Long
Declare Function CreateFontIndirect Lib "gdi32" _
                                    Alias "CreateFontIndirectA" ( _
                                    lpLogFont As LOGFONT) As Long
Declare Function CreateHatchBrush& Lib "gdi32" ( _
                                    ByVal nIndex As Long, _
                                    ByVal crColor As Long)
Declare Function CreatePen& Lib "gdi32" (ByVal nPenStyle As Long, _
                                    ByVal nWidth As Long, _
                                    ByVal crColor As Long)
Declare Function CreateSolidBrush& Lib "gdi32" (ByVal crColor As Long)
Declare Function LineTo& Lib "gdi32" (ByVal hDc As Long, _
                                    ByVal x As Long, _
                                    ByVal y As Long)
Declare Function MoveToEx Lib "gdi32" (ByVal hDc As Long, _
                                    ByVal x As Long, _
                                    ByVal y As Long, _
                                    lpPoint As POINTAPI) As Long
Declare Function RECTANGLE& Lib "gdi32" Alias "Rectangle" ( _
                                    ByVal hDc As Long, _
                                    ByVal X1 As Long, _
                                    ByVal Y1 As Long, _
                                    ByVal X2 As Long, _
                                    ByVal Y2 As Long)
Declare Function RoundRect Lib "gdi32" (ByVal hDc As Long, _
                                    ByVal X1 As Long, _
                                    ByVal Y1 As Long, _
                                    ByVal X2 As Long, _
                                    ByVal Y2 As Long, _
                                    ByVal X3 As Long, _
                                    ByVal Y3 As Long) As Long
Declare Function RestoreDC& Lib "gdi32" (ByVal hDc As Long, _
                                    ByVal nSavedDC As Long)
Declare Function SaveDC& Lib "gdi32" (ByVal hDc As Long)
Declare Function SetMapMode& Lib "gdi32" (ByVal hDc As Long, _
                                    ByVal nMapMode As Long)
Declare Function SetViewportExtEx& Lib "gdi32" (ByVal hDc As Long, _
                                    ByVal nX As Long, _
                                    ByVal nY As Long, _
                                    lpSize As Size)
Declare Function SetViewportOrgEx& Lib "gdi32" (ByVal hDc As Long, _
                                    ByVal nX As Long, _
                                    ByVal nY As Long, _
                                    lpPoint As POINTAPI)
Declare Function SetWindowOrgEx& Lib "gdi32" (ByVal hDc As Long, _
                                    ByVal nX As Long, _
                                    ByVal nY As Long, _
                                    lpPoint As POINTAPI)
Declare Function SetWindowExtEx& Lib "gdi32" (ByVal hDc As Long, _
                                    ByVal nX As Long, _
                                    ByVal nY As Long, _
                                    lpSize As Size)

Public Declare Function SetBkMode Lib "gdi32" (ByVal ln As Long, _
                                    ByVal nBkMode As Long) As Long
Public Declare Function SetBkColor Lib "gdi32" (ByVal ln As Long, _
                                    ByVal crColor As Long) As Long
Public Declare Function SetTextColor Lib "gdi32" (ByVal ln As Long, _
                                    ByVal crColor As Long) As Long
Public Declare Function DrawText Lib "user32" Alias "DrawTextA" ( _
                                    ByVal ln As Long, _
                                    ByVal lpStr As String, _
                                    ByVal nCount As Long, _
                                    lpRect As RECT, _
                                    ByVal wFormat As Long) As Long

Public Const DT_BOTTOM = &H8
Public Const DT_CALCRECT = &H400
Public Const DT_SINGLELINE = &H1
Public Const DT_CENTER = &H1
Public Const DT_LEFT = &H0
Public Const DT_RIGHT = &H2
Public Const DT_TOP = &H0
Public Const DT_VCENTER = &H4
Public Const TRANSPARENT = 1
Public Const OPAQUE = 2
Public Const NULL_BRUSH = 5
Public Const NULL_PEN = 8
Public Const BLACK_PEN = 7
Public Const WHITE_BRUSH = 0
Public Const WHITE_PEN = 6
Public Const PS_SOLID = 0


Function Ret_Width_Height(bar As BBAR_INFO, ByVal ln&) As RET_VAL
    '本函数用于计算条码的宽度和高度
    Dim r2&, r1&, a&, b&, hgt&, Width&, extra&
    Dim str$, align$, textdisp$
    Dim str2$
    Dim RetVal As RET_VAL
    Dim nfnt&
    
    '结构体赋值
    a = bar.lLeft
    b = bar.lTop
    hgt = bar.lheight
    Width = bar.lWidth
    r2 = bar.lR1
    r2 = 1
    r1 = 1
    str = bar.szReadText
    '文本对齐方式
    Select Case (bar.lalign)
        Case 1: align = "LEFT"
        Case 2: align = "CENTER"
        Case 3: align = "RIGHT"
        Case 4: align = "JUSTIFY"
        Case Else: align = "CENTER"
    End Select

    If (bar.ltxtdisp = 1) Then
         textdisp = "BOTTOM"
    ElseIf (bar.ltxtdisp = 2) Then
         textdisp = "TOP"
    Else
         textdisp = "BOTTOM"
    End If
    extra = bar.lExtra
   
    str2 = str
    Dim x&, wd&, w&, sum&, a1
    Dim rect1  As RECT
    a1 = a
    Dim lf As LOGFONT
    Dim hDc&
    hDc = ln
    '设定旋转角度
    If (bar.lRotation = 1) Then
        lf.lfEscapement = 900
    End If
    If (bar.lRotation = 2) Then
        lf.lfEscapement = 1800
    End If
    If (bar.lRotation = 0) Then
        lf.lfEscapement = 3600
    End If
    If (bar.lRotation = 3) Then
        lf.lfEscapement = 2700
    End If
 
    Dim ByteArrayLimit&, X1%
    Dim TempByteArray() As Byte
    TempByteArray = StrConv(bar.tiFaceName & Chr$(0), vbFromUnicode)
    ByteArrayLimit = UBound(TempByteArray)
    For X1% = 0 To ByteArrayLimit
    lf.lfFaceName(X1%) = TempByteArray(X1%)
    Next X1%

    Dim py%
    If ((bar.lRotation = 2) Or (bar.lRotation = 0)) Then
        py = GetDeviceCaps(hDc, 90)
    Else
        py = GetDeviceCaps(hDc, 88)
    End If

    If (bar.nsize > 0) Then
        'MulDiv函数将两个32位数相乘，所得64位数再除以另一个32位数
        lf.lfHeight = -MulDiv(bar.nsize, py, 72)
    Else
        lf.lfHeight = bar.nsize
    End If
           
    Select Case (bar.lstyle)
        Case 15:
            lf.lfItalic = 255
            lf.lfWeight = 700
            lf.lfUnderline = 1
            lf.lfStrikeOut = 1