资源说明：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 = PrnPrn.tBar.Width / ((eP - sP) + 1) PrnPrn.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) TempPrint Format(X1 * mm) TempPrint Format(Y1 * mm) TempPrint Format(MyCol) TempPrint "BF" End Sub Sub PrintBoxFill2(X As Single, Y As Single, X1 As Single, Y1 As Single, MyCol As Long, MyFil As Long, Dst As Integer) TempPrint "#fill" TempPrint Format(MyFil) TempPrint "#color" TempPrint Format(MyCol) TempPrint "#line" TempPrint Format(X * mm) TempPrint Format(Y * mm) TempPrint Format(X1 * mm) TempPrint Format(Y1 * mm) TempPrint "" TempPrint "B" End Sub Sub PrintBox(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 "B" End Sub Sub PrintImg(Nome As Control, X As Single, Y As Single, X1 As Single, Y1 As Single, Dst As Integer) Static RR As Single, RT As String, NI As String TempPrint "#img" RR = (899999 * Rnd) + 100000 RT = Format(RR, "000000") NI = LocPerc + "_$$_" + RT + ".tmp" TempPrint NI SavePicture Nome, NI TempPrint Format(X * mm) TempPrint Format(Y * mm) TempPrint Format(X1 * mm) TempPrint Format(Y1 * mm) End Sub Sub SetA3() PrnPrv.Prv.Cls PrnPrv.Prv.Width = PrnPrv.Prv.Height * (29.7 / 42) PrnPrv.Prv.ScaleWidth = mm * 29.7 PrnPrv.Prv.ScaleHeight = mm * 42 Scala = PrnPrv.Prv.Height / PrnPrv.Prv.ScaleHeight End Sub Sub SetA4() PrnPrv.Prv.Cls PrnPrv.Prv.Width = PrnPrv.Prv.Height * (21 / 29.7) PrnPrv.Prv.ScaleWidth = mm * 21 PrnPrv.Prv.ScaleHeight = mm * 29.7 Scala = PrnPrv.Prv.Height / PrnPrv.Prv.ScaleHeight End Sub Sub SetB5() PrnPrv.Prv.Cls PrnPrv.Prv.Width = PrnPrv.Prv.Height * (15 / 21) PrnPrv.Prv.ScaleWidth = mm * 15 PrnPrv.Prv.ScaleHeight = mm * 21 Scala = PrnPrv.Prv.Height / PrnPrv.Prv.ScaleHeight End Sub Sub TempShow(X01 As Single, Y01 As Single, X02 As Single, Y02 As Single) PrnPrv.MousePointer = vbHourglass Static OldFill As Long, OldColo As Long Static l As Integer, Lung As Single, dX As Single, tmpX As Single Static pPnt As Integer, pRef As Integer pPnt = 0 pRef = Val(PrnPrv.ePag.Text) Static A As String, B As String Static X As Single, Y As Single Static X1 As Single, Y1 As Single Static BoxColor As Long, BoxType As String PrnPrv.Prv.Cls 'PrnPrv.Prv.Scale (X01, Y01)-(X02, Y02) PrnPrv.Prv.Left = (X01 * -1) + NM_PP_Ofs PrnPrv.Prv.Top = (Y01 * -1) + NM_PP_Ofs + PrnPrv.Cmd(0).Height Open LocPerc + LocName For Input As #26 While Not EOF(26) Line Input #26, A If A = "#line" Then Line Input #26, A X = StripComma(A) Line Input #26, A Y = StripComma(A) Line Input #26, A X1 = StripComma(A) Line Input #26, A Y1 = StripComma(A) Line Input #26, A B = A BoxColor = StripComma(A) Line Input #26, A BoxType = A If pPnt = pRef Then If B = "" And BoxType = "" Then PrnPrv.Prv.Line (X, Y)-(X1, Y1) ElseIf B <> "" Then PrnPrv.Prv.Line (X, Y)-(X1, Y1), BoxColor, BF Else PrnPrv.Prv.Line (X, Y)-(X1, Y1), , B End If End If ElseIf A = "#x" Then Line Input #26, A If pPnt = pRef Then PrnPrv.Prv.CurrentX = StripComma(A) End If ElseIf A = "#y" Then Line Input #26, A If pPnt = pRef Then PrnPrv.Prv.CurrentY = StripComma(A) End If ElseIf A = "#txt_c" Then Line Input #26, A If pPnt = pRef Then dX = Int(PrnPrv.Prv.TextWidth(A) / 2) tmpX = PrnPrv.Prv.CurrentX - dX PrnPrv.Prv.Print A End If ElseIf A = "#txt_l" Then Line Input #26, A If pPnt = pRef Then PrnPrv.Prv.Print A End If ElseIf A = "#txt_r" Then Line Input #26, A If pPnt = pRef Then Lung = PrnPrv.Prv.TextWidth(A) PrnPrv.Prv.CurrentX = PrnPrv.Prv.CurrentX - Lung PrnPrv.Prv.Print A End If ElseIf A = "#fontname" Then Line Input #26, A If pPnt = pRef Then PrnPrv.Prv.FontName = A End If ElseIf A = "#fontsize" Then Line Input #26, A If pPnt = pRef Then PrnPrv.Prv.FontSize = StripComma(A) * Scala End If ElseIf A = "#fontbold" Then Line Input #26, A If pPnt = pRef Then If A = "0" Then PrnPrv.Prv.FontBold = False Else PrnPrv.Prv.FontBold = True End If End If ElseIf A = "#fill" Then Line Input #26, A If pPnt = pRef Then PrnPrv.Prv.FillStyle = CLng(Val(A)) End If ElseIf A = "#color" Then Line Input #26, A If pPnt = pRef Then PrnPrv.Prv.FillColor = CLng(Val(A)) End If ElseIf A = "#img" Then Line Input #26, A If TempFileExists(A) = True Then PrnPrv.Img.Picture = LoadPicture(A) End If Line Input #26, A X = StripComma(A) Line Input #26, A Y = StripComma(A) Line Input #26, A X1 = StripComma(A) Line Input #26, A Y1 = StripComma(A) If pPnt = pRef Then PrnPrv.Prv.PaintPicture PrnPrv.Img.Picture, X, Y, X1, Y1 End If ElseIf A = "#startpage" Then pPnt = pPnt + 1 ElseIf A = "#endpage" Then If pPnt = pRef Then GoTo BastaLeggere End If End If Wend BastaLeggere: Close #26 If PrnPrv.Prv.Width > PrnPrv.hBar.Width Then PrnPrv.hBar.Min = 0 PrnPrv.hBar.Max = PrnPrv.Prv.Width - PrnPrv.hBar.Width PrnPrv.hBar.SmallChange = 20 'PrnPrv.hBar.LargeChange = PrnPrv.hBar.Max / 10 PrnPrv.hBar.LargeChange = (PrnPrv.hBar.Width * PrnPrv.hBar.Max) / PrnPrv.Prv.Width Else PrnPrv.hBar.Min = 0 PrnPrv.hBar.Max = 0 End If If PrnPrv.Prv.Height > PrnPrv.vBar.Height Then PrnPrv.vBar.Min = 0 PrnPrv.vBar.Max = PrnPrv.Prv.Height - PrnPrv.vBar.Height PrnPrv.vBar.SmallChange = 20 'PrnPrv.vBar.LargeChange = PrnPrv.vBar.Max / 10 PrnPrv.vBar.LargeChange = (PrnPrv.vBar.Height * PrnPrv.vBar.Max) / PrnPrv.Prv.Height Else PrnPrv.vBar.Min = 0 PrnPrv.vBar.Max = 0 End If SistemaStatusBar PrnPrv.MousePointer = vbDefault End Sub Sub TempStampa(sP As Integer, eP As Integer) PrnPrv.MousePointer = vbHourglass PrnPrn.Command2.Font.Bold = True DoEvents PrnPrn.pBar.Width = 0 Static DaStampare As Boolean DaStampare = False Static l As Integer, Lung As Single, dX As Single, tmpX As Single Static pPnt As Integer, pRef As Integer pPnt = 0 pRef = Val(PrnPrv.ePag.Text) Static A As String, B As String Static X As Single, Y As Single Static X1 As Single, Y1 As Single Static BoxColor As Long, BoxType As String Open LocPerc + LocName For Input As #26 While Not EOF(26) Line Input #26, A If A = "#line" Then Line Input #26, A X = StripComma(A) Line Input #26, A Y = StripComma(A) Line Input #26, A X1 = StripComma(A) Line Input #26, A Y1 = StripComma(A) Line Input #26, A B = A BoxColor = StripComma(A) Line Input #26, A BoxType = A If DaStampare = True Then If B = "" And BoxType = "" Then Printer.Line (X, Y)-(X1, Y1) ElseIf B <> "" Then Printer.Line (X, Y)-(X1, Y1), BoxColor, BF Else Printer.Line (X, Y)-(X1, Y1), , B End If End If ElseIf A = "#x" Then Line Input #26, A If DaStampare = True Then Printer.CurrentX = StripComma(A) End If ElseIf A = "#y" Then Line Input #26, A If DaStampare = True Then Printer.CurrentY = StripComma(A) End If ElseIf A = "#txt_c" Then Line Input #26, A If DaStampare = True Then dX = Int(Printer.TextWidth(A) / 2) tmpX = Printer.CurrentX - dX Printer.Print A End If ElseIf A = "#txt_l" Then Line Input #26, A If DaStampare = True Then Printer.Print A End If ElseIf A = "#txt_r" Then Line Input #26, A If DaStampare = True Then Lung = Printer.TextWidth(A) Printer.CurrentX = Printer.CurrentX - Lung Printer.Print A End If ElseIf A = "#fontname" Then Line Input #26, A If DaStampare = True Then Printer.FontName = A End If ElseIf A = "#fontsize" Then Line Input #26, A If DaStampare = True Then Printer.FontSize = StripComma(A) End If ElseIf A = "#fontbold" Then Line Input #26, A If DaStampare = True Then If A = "0" Then Printer.FontBold = False Else Printer.FontBold = True End If End If ElseIf A = "#fill" Then Line Input #26, A If pPnt = pRef Then Printer.FillStyle = CLng(Val(A)) End If ElseIf A = "#color" Then Line Input #26, A If pPnt = pRef Then Printer.FillColor = CLng(Val(A)) End If ElseIf A = "#img" Then Line Input #26, A If TempFileExists(A) = True Then PrnPrv.Img.Picture = LoadPicture(A) End If Line Input #26, A X = StripComma(A) Line Input #26, A Y = StripComma(A) Line Input #26, A X1 = StripComma(A) Line Input #26, A Y1 = StripComma(A) If DaStampare = True Then Printer.PaintPicture PrnPrv.Img.Picture, X, Y, X1, Y1 End If ElseIf A = "#startpage" Then If NM_AnnullaStampa = True Then GoTo BastaLeggere pPnt = pPnt + 1 If pPnt > eP Then GoTo BastaLeggere ElseIf pPnt >= sP And pPnt <= eP Then DaStampare = True SistemaBarra sP, eP, pPnt DoEvents ElseIf pPnt < sP Then DaStampare = False End If ElseIf A = "#endpage" Then If NM_AnnullaStampa = True Then GoTo BastaLeggere If pPnt >= eP Then GoTo BastaLeggere If DaStampare = True Then Printer.NewPage End If Wend BastaLeggere: Printer.EndDoc Close #26 PrnPrn.Command2.Font.Bold = False PrnPrv.MousePointer = vbDefault End Sub

联系我们：verysource_com

CopyRight © 2008-2022 verySource.Com All Rights reserved.　京ICP备17048824号-1　京公网安备：11010502034788