module1.bas

一个简单的公司进销存管理系统

Attribute VB_Name = "Module1"

Option Explicit

Global Const mm = 567
Global Const cm = 567
Global Const NM_PP_Ofs = 0 '36

Global Const Gray = &HC0C0C0
Global Scala As Single

Global Const ANTEPRIMA = 0
Global Const STAMPANTE = 1

Global Const NONESCLUSIVO = 0
Global Const ESCLUSIVO = 1

Global LocPerc As String
Global Const LocName = "_$$_TEMP.TMP"

Global Ofs As Single

Global Const SistemaCoordinate = 0

Global NM_AnnullaStampa As Boolean
Global TempDemoMode As Boolean

Sub SistemaBarra(sP As Integer, eP As Integer, aP As Integer)

    ' PrnPRN.sBar > max bar
    ' PrnPRN.aBar > actual value
    '
    ' sP = start page
    ' eP = end page
    ' aP = actual page
    
    Static Stp As Single
   ' Stp = PrnPRN1.tBar.Width / ((eP - sP) + 1)
    
   ' PrnPRN1.pBar.Width = Stp * aP

End Sub

Function TempFileExists(MyFilename As String) As Boolean

Dim TempAttr As Double
TempFileExists = True

On Error GoTo MyErrorFileExist

    TempAttr = FileLen(MyFilename)
    GoTo MyExitFileExist
   
MyErrorFileExist:
    TempFileExists = False
    Resume MyExitFileExist
   
MyExitFileExist:
    On Error GoTo 0

End Function



Sub ContaPagine()

    PrnPRV.MousePointer = vbHourglass

    Static NumPag As Integer
    NumPag = 0
    Static A As String, B As String
    
    PrnPRV.ePag.Clear
    
    Open LocPerc + LocName For Append As #27: Close #27
    '@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
    Open LocPerc + LocName For Input As #27
        While Not EOF(27)
            Line Input #27, A
            If A = "#startpage" Then
                NumPag = NumPag + 1
            ElseIf A = "#endpage" Then
                PrnPRV.ePag.AddItem Format(NumPag)
            End If
        Wend
    Close #27
    
    If PrnPRV.ePag.ListCount > 0 Then
        PrnPRV.ePag.ListIndex = 0
    Else
        PrnPRV.MousePointer = vbDefault
        MsgBox "No pages to print!", vbInformation, "Preview non available"
        Unload PrnPRV
    End If
    
    PrnPRV.MousePointer = vbDefault

End Sub

Sub SistemaStatusBar()

    PrnPRV.aPag.Caption = PrnPRV.ePag.Text
    PrnPRV.tPag.Caption = PrnPRV.ePag.ListCount
    PrnPRV.zPag.Caption = PrnPRV.zVal.Text + "%"

End Sub


Function StripComma(S As String) As Single

    Static l As Integer

    For l = 1 To Len(S)
        If Mid(S, l, 1) = "," Then
            Mid(S, l, 1) = "."
        End If
    Next
    
    StripComma = Val(S)

End Function

Sub TempDelete()
    Open LocPerc + LocName For Append As #25
    Close #25
    Kill LocPerc + LocName
End Sub

Sub TempInit()

    PrnPRV.TmpList.Pattern = "_$$_*.TMP"
    PrnPRV.TmpList.Path = Left(LocPerc, Len(LocPerc) - 1)
    PrnPRV.TmpList.Refresh
    If PrnPRV.TmpList.ListCount > 0 Then
        Kill LocPerc + "_$$_*.TMP"
    End If

    Randomize 1

    Open LocPerc + LocName For Output As #25
    Close #25
    Unload PrnPRV
    
End Sub

Sub TempPrint(Dato As String)
    Open LocPerc + LocName For Append As #25
        Print #25, Dato
    Close #25
End Sub

Sub PrintHeader(Sin As String, Des As String, Dst As Integer)
    
    TempPrint "#startpage"
    PrintBox 2, 0.9, 18, 0.91, ANTEPRIMA
    PrintInLef 2, 0.55, Sin, "Arial", 8, False, ANTEPRIMA
    PrintInRig 18, 0.55, Des, "Arial", 8, False, ANTEPRIMA
    If TempDemoMode = True Then
        PrintCross 2, 0.9, 17.9, 26.01, ANTEPRIMA
        PrintCross 2.1, 0.9, 18, 26.01, ANTEPRIMA
    End If

End Sub


Sub PrintFooter(Sin As String, Des As String, Dst As Integer)

    PrintBox 2, 26, 18, 26.01, ANTEPRIMA
    PrintInLef 2, 26.1, Sin, "Arial", 8, False, ANTEPRIMA
    PrintInRig 18, 26.1, Des, "Arial", 8, False, ANTEPRIMA
    TempPrint "#endpage"
    ContaPagine
    
End Sub


Sub PrintRefGrid(Dst As Integer)

    Static X, Y As Integer
    
    TempPrint "#fontname"
    TempPrint "Arial"
    TempPrint "#fontsize"
    TempPrint Format(6 * Scala)
    
    For Y = 0 To 26
        TempPrint "#y"
        TempPrint Format(Y * mm)
        For X = 0 To 19
            TempPrint "#x"
            TempPrint Format(X * mm)
            TempPrint "#txt"
            TempPrint "+" & Format$(X, "#,##0") & "," & Format$(Y, "#,##0")
        Next
    Next

End Sub

Sub PrintJust(X As Single, Y As Single, Phrase As String, Fname As String, Fsize As Integer, Fbold As Integer, Larg As Single, Dst As Integer)

    ReDim aT(500) As String
    Static NumPar As Integer
    Static aP As String
    Static OaP As String
    Static lP, l As Integer
    Static VecOfs As Single
    Static Interl As Single
    
    PrnPRV.Prv.FontName = Fname
    PrnPRV.Prv.FontSize = Fsize
    PrnPRV.Prv.FontBold = Fbold
    
    'Interl = PrnPrv.Prv.TextHeight(Phrase)
    Interl = 0.4
    
    If PrnPRV.Prv.TextWidth(Phrase) > Larg * mm Then
        NumPar = 0
        For l = 1 To Len(Phrase)
            If Mid$(Phrase, l, 1) = " " Then
                NumPar = NumPar + 1
            Else
                aT(NumPar) = aT(NumPar) + Mid$(Phrase, l, 1)
            End If
        Next
        aP = ""
        lP = 0
        For l = 0 To NumPar
            OaP = aP
            If aP = "" Then
                aP = aT(l)
            Else
                aP = aP + " " + aT(l)
            End If
            If PrnPRV.Prv.TextWidth(aP) > Larg * mm Then
                aP = OaP
                PrintInLef X, Y + (Interl * lP), aP, Fname, Fsize, Fbold, ANTEPRIMA
                Ofs = Ofs + Interl
                aP = aT(l)
                lP = lP + 1
            End If
        Next
        PrintInLef X, Y + (Interl * lP), aP, Fname, Fsize, Fbold, ANTEPRIMA
        Ofs = Ofs + Interl
    Else
        PrintInLef X, Y, Phrase, Fname, Fsize, Fbold, ANTEPRIMA
        Ofs = Ofs + Interl
    End If

End Sub

Sub PrintJustS(X As Single, Y As Single, Phrase As String, Fname As String, Fsize As Integer, Fbold As Integer, Larg As Single, Dst As Integer)

    ReDim aT(500) As String
    Static NumPar As Integer
    Static aP As String
    Static OaP As String
    Static lP, l As Integer
    Static VecOfs As Single
    Static lStp As Single
    lStp = 0.3

    PrnPRV.Prv.FontName = Fname
    PrnPRV.Prv.FontSize = Fsize
    PrnPRV.Prv.FontBold = Fbold
    If PrnPRV.Prv.TextWidth(Phrase) > Larg * mm Then
        NumPar = 0
        For l = 1 To Len(Phrase)
            If Mid$(Phrase, l, 1) = " " Then
                NumPar = NumPar + 1
            Else
                aT(NumPar) = aT(NumPar) + Mid$(Phrase, l, 1)
            End If
        Next
        aP = ""
        lP = 0
        For l = 0 To NumPar
            OaP = aP
            If aP = "" Then
                aP = aT(l)
            Else
                aP = aP + " " + aT(l)
            End If
            If PrnPRV.Prv.TextWidth(aP) > Larg * mm Then
                aP = OaP
                PrintInLef X, Y + (lStp * lP), aP, Fname, Fsize, Fbold, ANTEPRIMA
                Ofs = Ofs + lStp
                aP = aT(l)
                lP = lP + 1
            End If
        Next
        PrintInLef X, Y + (lStp * lP), aP, Fname, Fsize, Fbold, ANTEPRIMA
        Ofs = Ofs + lStp
    Else
        PrintInLef X, Y, Phrase, Fname, Fsize, Fbold, ANTEPRIMA
        Ofs = Ofs + lStp
    End If

End Sub


Sub PrintInRig(X As Single, Y As Single, Phrase As String, Fname As String, Fsize As Integer, Fbold As Integer, Dst As Integer)

Static Tmp As String
Static Lungh As Single

    Lungh = PrnPRV.Prv.TextWidth(Phrase)
        
    TempPrint "#fontname"
    TempPrint Fname
    TempPrint "#fontsize"
    TempPrint Format(Fsize)
    TempPrint "#fontbold"
    TempPrint Format(Fbold)
    TempPrint "#y"
    TempPrint Format(Y * mm)
    TempPrint "#x"
    TempPrint Format(X * mm) ' - Lungh
    TempPrint "#txt_r"
    TempPrint Phrase

End Sub

Sub PrintInLef(X As Single, Y As Single, Phrase As String, Fname As String, Fsize As Integer, Fbold As Integer, Dst As Integer)

    TempPrint "#fontname"
    TempPrint Fname
    TempPrint "#fontsize"
    TempPrint Format(Fsize)
    TempPrint "#fontbold"
    TempPrint Format(Fbold)
    TempPrint "#y"
    TempPrint Format(Y * mm)
    TempPrint "#x"
    TempPrint Format(X * mm)
    TempPrint "#txt_l"
    TempPrint Phrase
    
End Sub

Sub PrintInCen(X As Single, Y As Single, Phrase As String, Fname As String, Fsize As Integer, Fbold As Integer, Dst As Integer)

    Static dX As Single
    Static tmpX As Single
'
'  X = coordinata orizzontale
'  Y = coordinata del centro della riga
'  Phrase = stringa da stampare
'
    

    dX = Int(PrnPRV.Prv.TextWidth(Phrase) / 2)
    tmpX = (X * mm) - (dX)

    If tmpX < 0 Then
        MsgBox "Error in coords!!!!", 16, "PrintInCen"
        Exit Sub
    End If

    TempPrint "#fontname"
    TempPrint Fname
    TempPrint "#fontsize"
    TempPrint Format(Fsize)
    TempPrint "#fontbold"
    TempPrint Format(Fbold)
    TempPrint "#y"
    TempPrint Format(Y * mm)
    TempPrint "#x"
    TempPrint Format(tmpX) '@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
    TempPrint "#txt_c"
    TempPrint Phrase

End Sub

Sub PrintCross(X As Single, Y As Single, X1 As Single, Y1 As Single, Dst As Integer)

    TempPrint "#fill"
    TempPrint "1"
    TempPrint "#color"
    TempPrint "0"
    TempPrint "#line"
    TempPrint Format(X * mm)
    TempPrint Format(Y * mm)
    TempPrint Format(X1 * mm)
    TempPrint Format(Y1 * mm)
    TempPrint ""
    TempPrint ""
    TempPrint "#line"
    TempPrint Format(X1 * mm)
    TempPrint Format(Y * mm)
    TempPrint Format(X * mm)
    TempPrint Format(Y1 * mm)
    TempPrint ""
    TempPrint ""


End Sub

Sub PrintBoxFill(X As Single, Y As Single, X1 As Single, Y1 As Single, MyCol As Long, Dst As Integer)

    TempPrint "#fill"
    TempPrint "1"
    TempPrint "#color"
    TempPrint "0"
    TempPrint "#line"
    TempPrint Format(X * mm)
    TempPrint Format(Y * mm)