🚀 go-pugleaf

Avendo un pulsante con questo codice:

Private Sub Stampa_Click()
    'Questo codice stampa il database.
        Set M = New FlexPrinter
        Set M.FlexName = MSFMagazzino
        xy = MSFMagazzino.Rows - 1
        If xy < 46 Then
        M.bDrawBoarder = False
        M.FillColor = vbYellow
        M.RowsFrom = 0
        M.RowsTo = 0
        M.PosLeft = 20
        M.PosTop = 130
        M.FillColor = vbWhite
        M.RowsFrom = 1
        M.RowsTo = MSFMagazzino.Rows - 1
        M.PosTop = M.CurY
        M.PrintOut Printer
        Printer.EndDoc
        End If

    Data1.Refresh
End Sub

Ed un "Class Modules" chiamato "FlexPrinter" :

Option Explicit

Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As
Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hDC As Long, ByVal
crColor As Long) As Long
Private Declare Function DrawText Lib "USER32" Alias "DrawTextA" (ByVal hDC
As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal
wFormat As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal
hObject As Long) As Long
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long,
ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function SendMessage Lib "USER32" Alias "SendMessageA"
(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As
Any) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As
Long
Private 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
Private Declare Function LineTo Lib "gdi32" (ByVal hDC As Long, ByVal X As
Long, ByVal Y As Long) As Long
Private Declare Function MoveToEx Lib "gdi32" (ByVal hDC As Long, ByVal X As
Long, ByVal Y As Long, lpPoint As POINTAPI) As Long


Private Type POINTAPI
        X As Long
        Y As Long
End Type

Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type
Dim objFlex As Object
Dim lRowsFrom As Long, lRowsTo As Long, lLeftPos As Long, lTopPos As Long
Dim FinalX As Long, FinalY As Long
'***********Publics***********
Public bGridPrint As Boolean
Public VSpace As Long, HSpace As Long
Public RoundCorX As Long, RoundCorY As Long
Public GridPenStyle As Long
Public FillColor As Long
Public bDrawBoarder As Boolean
Public BoarderStyle As Long, BoarderColor As Long, BoarderWidth As Long,
BoarderDistance As Long

Const DT_LEFT = 0
Const DT_TOP = 0
Const DT_CENTER = 1
Const DT_RIGHT = 2
Const DT_VCENTER = 4
Const DT_BOTTOM = 8
Const DT_WORDBREAK = 16
Const DT_SINGLELINE = 32
Const DT_NOPREFIX = 2048
Const DT_END_ELLIPSIS = 32768
Const DT_MODIFYSTRING = 65536
Const DT_WORD_ELLIPSIS = 262144







Public Sub PrintOut(Obj As Object)
Dim lRows As Long, lCols As Long
Dim cellHeight As Long, cellWidth As Long
Dim tmpLeft As Long, rectBox As RECT
Dim lDrawWidth As Long
Dim sCellText As String, cellFont As StdFont
Dim lTextColor, iAlignment As Integer
Dim TmpJustToHold As Long, DT_Code As Long, bWordWrap As Boolean
Dim TmpJustTohold2 As Long
Dim lGridLineColor As Long
Dim lOldPen As Long, lNewPen As Long
Dim lOldBrush As Long, lNewBrush As Long
Dim BorX As Long, BorY As Long, BorDx As Long, BorDy As Long
Dim opal As POINTAPI, TmpDrawWidth As Long, TmpBoarderWidth As Long
Dim TmpBoarderDistance As Long
'*********************************************************

If Not ValidObj(Obj) Then Exit Sub

Set cellFont = New StdFont
Obj.ScaleMode = vbPixels
Obj.Print
With objFlex
    lDrawWidth = .GridLineWidth
    bWordWrap = .WordWrap
   .Redraw = False
    lGridLineColor = .GridColor

End With 'objFlex
BorX = lLeftPos
BorY = lTopPos

TmpBoarderWidth = BoarderWidth: TmpDrawWidth = lDrawWidth:
TmpBoarderDistance = BoarderDistance
TmpJustTohold2 = 1
If TypeName(Obj) = "Printer" Then

    TmpJustToHold = Screen.TwipsPerPixelX / Printer.TwipsPerPixelX
    lDrawWidth = lDrawWidth * TmpJustToHold
    BoarderWidth = BoarderWidth * TmpJustToHold
    TmpJustTohold2 = TmpJustToHold
End If  'TypeName(obj) = "Printer"


For lRows = lRowsFrom To lRowsTo

    cellHeight = Obj.ScaleY(objFlex.RowHeight(lRows), vbTwips, vbPixels)

    tmpLeft = lLeftPos
            For lCols = 0 To objFlex.Cols - 1
               With objFlex
                     .Col = lCols: .Row = lRows
                      sCellText = objFlex.Text
                                     cellFont.Name = .CellFontName:
cellFont.Size = .CellFontSize
                                     cellFont.Bold = .CellFontBold:
cellFont.Underline = .CellFontUnderline
                                     cellFont.Strikethrough =
.CellFontStrikeThrough: cellFont.Italic = .CellFontItalic
                     lTextColor = .CellForeColor: TmpJustToHold =
.CellAlignment
                    If bWordWrap Then DT_Code = DT_WORDBREAK Or DT_NOPREFIX
Or DT_END_ELLIPSIS Or DT_MODIFYSTRING Else DT_Code = DT_SINGLELINE Or
DT_NOPREFIX
                            Select Case TmpJustToHold
                                    Case 0
                                    DT_Code = DT_Code Or DT_LEFT Or DT_TOP
                                    Case 1
                                    DT_Code = DT_Code Or DT_VCENTER Or
DT_LEFT
                                    Case 2
                                    DT_Code = DT_Code Or DT_LEFT Or
DT_BOTTOM
                                    Case 3
                                    DT_Code = DT_Code Or DT_CENTER Or DT_TOP
                                    Case 4
                                    DT_Code = DT_Code Or DT_VCENTER Or
DT_CENTER
                                    Case 5
                                    DT_Code = DT_Code Or DT_CENTER Or
DT_BOTTOM
                                    Case 6
                                    DT_Code = DT_Code Or DT_RIGHT Or DT_TOP
                                    Case 7
                                    DT_Code = DT_Code Or DT_RIGHT Or
DT_VCENTER
                                    Case 8
                                    DT_Code = DT_Code Or DT_BOTTOM Or
DT_RIGHT
                                    Case 9
                                            If IsNumeric(sCellText) Or
IsDate(sCellText) Then DT_Code = DT_Code Or DT_RIGHT Or DT_VCENTER Else
DT_Code = DT_Code Or DT_LEFT Or DT_VCENTER

                           End Select

                End With 'objFlex

                cellWidth = Obj.ScaleX(objFlex.ColWidth(lCols), vbTwips,
vbPixels)

                   With rectBox
                        .Left = lLeftPos: .Top = lTopPos
                        .Right = lLeftPos + cellWidth: .Bottom = lTopPos +
cellHeight

                         If bGridPrint Then
                                lNewBrush = CreateSolidBrush(FillColor)
                                lNewPen = CreatePen(GridPenStyle,
lDrawWidth, lGridLineColor)
                                lOldBrush = SelectObject(Obj.hDC, lNewBrush)
                                lOldPen = SelectObject(Obj.hDC, lNewPen)
                                RoundRect Obj.hDC, .Left, .Top, .Right +
lDrawWidth, .Bottom + lDrawWidth, Obj.ScaleX(RoundCorX, vbTwips, vbPixels),
Obj.ScaleY(RoundCorY, vbTwips, vbPixels)
                                DeleteObject (lOldPen): DeleteObject
(lOldBrush)
                         End If 'bGridPrint
                        'Making rectBox a bit smaller, so that the text
should not touch the lines
                        .Left = .Left + (3 * TmpJustTohold2): .Right =
.Right - (3 * TmpJustTohold2): .Top = .Top + (2 * TmpJustTohold2): .Bottom =
.Bottom - (2 * TmpJustTohold2)
                   End With  ' rectBox
                Set Obj.Font = cellFont

                 SetTextColor Obj.hDC, lTextColor
                 DrawText Obj.hDC, sCellText, Len(sCellText), rectBox,
DT_Code

                lLeftPos = lLeftPos + cellWidth + (VSpace * TmpJustTohold2)
'VSpace = Vertical Spacing
        Next lCols    'For lCols = 1 To flex.cols

    lTopPos = lTopPos + cellHeight + (HSpace * TmpJustTohold2) 'Horizontal
Spacing
    lLeftPos = tmpLeft
Next lRows   'For lRows = lRowsFrom To lRowsTo

BorDx = rectBox.Right + lDrawWidth + (2 * TmpJustTohold2)
BorDy = rectBox.Bottom + (2 * TmpJustTohold2)

FinalX = BorDx: FinalY = BorDy

If bDrawBoarder Then

        lNewPen = CreatePen(BoarderStyle, BoarderWidth, BoarderColor)
        lOldPen = SelectObject(Obj.hDC, lNewPen)
        BoarderDistance = BoarderDistance * TmpJustTohold2
        BorX = BorX - BoarderDistance: BorY = BorY - BoarderDistance
        BorDx = BorDx + BoarderDistance: BorDy = BorDy + BoarderDistance

        MoveToEx Obj.hDC, BorDx, BorDy, opal  'Starting point Dx Dy
        LineTo Obj.hDC, BorX, BorDy        'MoveRight
        LineTo Obj.hDC, BorX, BorY          'MoveUp
        LineTo Obj.hDC, BorDx, BorY        'Moveleft
        LineTo Obj.hDC, BorDx, BorDy      'MoveDown to starting point
        SelectObject Obj.hDC, lOldPen
        DeleteObject lNewPen
        FinalX = BorDx: FinalY = BorDy
End If
objFlex.Redraw = True
Set cellFont = Nothing
BoarderWidth = TmpBoarderWidth: lDrawWidth = TmpDrawWidth
BoarderDistance = TmpBoarderDistance
End Sub

Public Property Set FlexName(ByVal NewValue As Object)
If TypeName(NewValue) = "MSHFlexGrid" Or TypeName(NewValue) = "MSFlexGrid"
Then
    Set objFlex = NewValue
Else
    MsgBox "Value to 'FlexName' property is invalid; it should be name of
the MSHFlexGrid control or MSFlexGrid control. ", vbCritical, "Invalid
Property"
End If
End Property
Public Property Let RowsTo(ByVal NewValue As Long)
lRowsTo = NewValue
End Property

Public Property Let RowsFrom(ByVal NewValue As Long)
lRowsFrom = NewValue
End Property

Public Property Let PosTop(ByVal NewValue As Long)
lTopPos = NewValue
End Property
Public Property Let PosLeft(ByVal NewValue As Long)
lLeftPos = NewValue
End Property


Private Sub Class_Initialize()
lRowsFrom = 0: lRowsTo = 1
bGridPrint = True
VSpace = 0: HSpace = 0   'V=Vertical  H=Horizontal
RoundCorX = 10: RoundCorY = 10: GridPenStyle = 0
FillColor = vbWhite: bDrawBoarder = True
BoarderStyle = 0: BoarderColor = vbBlack: BoarderWidth = 1: BoarderDistance
= 5

End Sub
Public Property Get CurX() As Long
CurX = FinalX
End Property
Public Property Get CurY() As Long
CurY = FinalY
End Property
Private Function ValidObj(objOP As Object) As Boolean
Dim Msg As String
If TypeOf objOP Is Form Or TypeOf objOP Is PictureBox Or TypeOf objOP Is
Printer Then
ValidObj = True
Else
ValidObj = False
End If
If Not ValidObj Then
Msg = "Invalid object " + vbCrLf
Msg = Msg + vbCrLf + vbCrLf
Msg = Msg + "The valid objects are Printer, PictureBox and Form" + vbCrLf
MsgBox Msg, vbCritical, "Invalid Object"
End If
End Function

Private Sub Class_Terminate()
Set objFlex = Nothing
End Sub
Public Sub DrawRulerH(Obj As Object, X As Long, Y As Long, Length As Long,
sUnit As String)

Dim Height As Long, Devide As Long
Dim SmallSteps  As Long, bSwitch As Boolean
Dim h1 As Long, TwpPerUnit As Long
Dim TmpK1 As Long
Dim K1 As Long, K2 As Long, N As Long
Dim BuFore As Long
Dim BuDrawStyle As Long, BuDrawWidth As Long, BuDrawMode As Long,
BuScaleMode As Long
Dim BuFontS As Long
If Not ValidObj(Obj) Then Exit Sub

'Back Up
BuDrawStyle = Obj.DrawStyle: BuDrawWidth = Obj.DrawWidth
BuDrawMode = Obj.DrawMode: BuFontS = Obj.FontSize
BuScaleMode = Obj.ScaleMode
BuFore = Obj.ForeColor
'Set
Obj.DrawStyle = vbSolid: Obj.DrawWidth = 1: Obj.DrawMode = vbCopyPen
Obj.ScaleMode = vbTwips: Obj.FontSize = 8
Obj.FontBold = False: Obj.FontItalic = False
Obj.FontStrikethru = False
Obj.FontUnderline = False
SetTextColor Obj.hDC, vbBlack
X = X * Screen.TwipsPerPixelX
Y = Y * Screen.TwipsPerPixelY

Height = 400

If UCase(sUnit) = "INCH" Then
TwpPerUnit = 1440
Devide = 20
Else
'CM
TwpPerUnit = 567
Devide = 6
End If


SmallSteps = TwpPerUnit / Devide
If bDrawBoarder Then
Y = Y - Height - ((BoarderDistance * Screen.TwipsPerPixelX) + 50) 'Top
position and borDis leftposition and Bordis
X = X - BoarderDistance * Screen.TwipsPerPixelY

Else
Y = Y - (Height + 50)
End If

Obj.Line (X, Y)-(X + Length, Y)
Obj.Line (X, Y + Height)-(X + Length, Y + Height)
N = -1
For K1 = 0 To Length Step TwpPerUnit
bSwitch = True: N = N + 1
Obj.Line (X + K1, Y)-(X + K1, Y + Height + 50), vbRed
''''''
Obj.Line (X + K1, Y + Height + 50)-(X + K1 - 50, Y + Height + 50 - 100),
vbRed
Obj.Line (X + K1, Y + Height + 50)-(X + K1 + 50, Y + Height + 50 - 100),
vbRed

Obj.CurrentY = Y + 30
Obj.CurrentX = Obj.CurrentX + 20 - Obj.TextWidth(Str(N)) / 2
If K1 = 0 Then Obj.Print "0 " + Mid(sUnit, 1, 2) + "." Else Obj.Print N

Obj.Line (X + K1 + TwpPerUnit / 2, Y)-(X + K1 + TwpPerUnit / 2, Y + Height)

    For K2 = TmpK1 + SmallSteps To K1 - SmallSteps Step SmallSteps
     bSwitch = Not bSwitch

     If bSwitch Then
     Obj.Line (X + K2, Y + Height - 200)-(X + K2, Y + Height)
     Else
     Obj.Line (X + K2, Y + Height - 100)-(X + K2, Y + Height)
     End If
     Next K2
    TmpK1 = K1

Next K1
'restore the things
   SetTextColor Obj.hDC, BuFore
Obj.DrawStyle = BuDrawStyle: Obj.DrawWidth = BuDrawWidth: Obj.DrawMode =
BuDrawMode
Obj.ScaleMode = BuScaleMode: Obj.FontSize = BuFontS
End Sub
Public Sub DrawRulerV(Obj As Object, X As Long, Y As Long, Length As Long,
sUnit As String)
Dim Height As Long, Devide As Long
Dim SmallSteps  As Long, bSwitch As Boolean
Dim h1 As Long, TwpPerUnit As Long
Dim TmpK1 As Long
Dim K1 As Long, K2 As Long, N As Long

Dim BuDrawStyle As Long, BuDrawWidth As Long, BuDrawMode As Long,
BuScaleMode As Long
Dim BuFontS As Long
Dim BuFore As Long
If Not ValidObj(Obj) Then Exit Sub
'Back Up
BuDrawStyle = Obj.DrawStyle: BuDrawWidth = Obj.DrawWidth
BuDrawMode = Obj.DrawMode: BuScaleMode = Obj.ScaleMode
BuFontS = Obj.FontSize
BuFore = Obj.ForeColor
'Set New
Obj.DrawStyle = vbSolid: Obj.DrawWidth = 1: Obj.DrawMode = vbCopyPen
Obj.ScaleMode = vbTwips: Obj.FontSize = 8: Obj.FontBold = False:
Obj.FontItalic = False
Obj.FontStrikethru = False
Obj.FontUnderline = False

SetTextColor Obj.hDC, vbBlack
X = X * Screen.TwipsPerPixelX: Y = Y * Screen.TwipsPerPixelY
Height = 400
Length = Obj.Height

If UCase(sUnit) = "INCH" Then
TwpPerUnit = 1440
Devide = 20
Else
'CM
TwpPerUnit = 567
Devide = 6
End If

SmallSteps = TwpPerUnit / Devide
If bDrawBoarder Then
X = X - Height - ((BoarderDistance * Screen.TwipsPerPixelX) + 50) 'Top
position and borDis leftposition and Bordis
Y = Y - BoarderDistance * Screen.TwipsPerPixelY
Else
X = X - (Height + 50)
End If

Obj.Line (X, Y)-(X, Y + Length)
Obj.Line (X + Height, Y)-(X + Height, Y + Length)
N = -1
For K1 = 0 To Length Step TwpPerUnit
bSwitch = True: N = N + 1
Obj.Line (X, Y + K1)-(X + Height + 50, Y + K1), vbRed
''''''
Obj.Line (X + Height + 50, Y + K1)-(X + Height - 50, Y + K1 - 50), vbRed
Obj.Line (X + Height + 50, Y + K1)-(X + Height - 50, Y + K1 + 50), vbRed

Obj.CurrentX = X - 30 + Obj.TextWidth(Str(N)) / 2
If K1 = 0 Then Obj.Print "0 " + Mid(sUnit, 1, 2) + "." Else Obj.Print N

Obj.Line (X, Y + K1 + TwpPerUnit / 2)-(X + Height, Y + K1 + TwpPerUnit / 2)

    For K2 = TmpK1 + SmallSteps To K1 - SmallSteps Step SmallSteps
     bSwitch = Not bSwitch

     If bSwitch Then
     Obj.Line (X + Height - 200, Y + K2)-(X + Height, Y + K2)
     Else
     Obj.Line (X + Height - 100, Y + K2)-(X + Height, Y + K2)
     End If
     Next K2
    TmpK1 = K1

Next K1
Obj.DrawStyle = BuDrawStyle: Obj.DrawWidth = BuDrawWidth: Obj.DrawMode =
BuDrawMode
Obj.ScaleMode = BuScaleMode: Obj.FontSize = BuFontS
   SetTextColor Obj.hDC, BuFore
End Sub
Public Sub ColSetupCode()
'Code Generator
Dim C As Long, R As Long
Dim cd As String

cd = cd + "'You can place this code in Form's load event" + vbCrLf + vbCrLf
cd = cd + "'MSFlex Grid Control does not require these code but MSHFlex
does" + vbCrLf + vbCrLf
cd = cd + "With " + objFlex.Name + vbCrLf

For C = 0 To objFlex.Cols - 1
R = objFlex.ColWidth(C)
If R < 1 Then cd = cd + "'You must set positive value to follwing line" +
vbCrLf
cd = cd + ".ColWidth(" + Str(C) + ")  =" + Str(R) + vbCrLf
Next C
cd = cd + "End With"
Clipboard.Clear ' Clear Clipboard.
Clipboard.SetText cd
MsgBox "Column setup code has been copied to cilipboard"

End Sub


Cosa devo fare per far si che il tutto funzioni? Per la precisione quando
avvio il programma e premo stampa
mi da errore "VARIABLE NOT DEFINITE" e mi rimanda alla riga: xy =
MSFMagazzino.Rows - 1
Qualcuno sa cosa devo fare? In attesa di risposta auguro a tutti Buone Feste
e ringrazio
anticipatamente chiunque mi aiuti...........Dominus