Public Declare Function Inp Lib "inpout32.dll" Alias "Inp32" (ByVal PortAddress As Integer) As Integer Public Declare Sub Out Lib "inpout32.dll" Alias "Out32" (ByVal PortAddress As Integer, ByVal Value As Integer) Public Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long) Public mm: Public ms: Public Vc: Public Vd Public Vc1: Public Vc2: Public Vd1: Public Vd2 Public F: Public PP0: Public PP1: Public PP2 Sub UpDown() '037A_04,10,09,15,03;0379_127 PP2 = &HBC02: PP1 = &HBC01: PP0 = &HBC00 0 strTime = InputBox(Prompt:="Tempo = millisecondi(circa)", _ Title:="PortaParallela: TimeSleep max=500", Default:="100") If strTime = vbNullString Then GoTo 0 If strTime > 500 Then strTime = 500 ms = 5: mm = strTime / 20: Range("U3") = mm * 5: Range("U5") = 1000 / (mm * 5) ' Vc = "10091503": Vd = "001002004008016032064128" ' 1 3 5 7 1 4 7 0 3 6 9 2 Vc2 = "10081204": Vc1 = "0405070311" ' 1 3 5 7 1 3 5 7 9 Vd2 = "000001003007015031063127255": Vd1 = "255254252248240224192128" ' 1 4 7 0 3 6 9 2 5 1 4 7 0 3 6 9 2 'End Sub 'Sub UP1() 1 If F = 1 Then GoTo 10 For nc = 1 To 7 Step 2 Out PP2, Mid(Vc, nc, 2) Cells(1, nc).Select Run "Neretto" For m = 1 To mm If Inp(PP1) > 127 Then GoTo 9 Call Controllo Sleep ms Next Run "Normale" Out PP2, 11 Next If F = 1 Then GoTo 10 For nd = 1 To 22 Step 3 Out PP0, Mid(Vd, nd, 3) Cells(1, nd + 8).Select Run "Neretto" For m = 1 To mm If Inp(PP1) > 127 Then GoTo 9 Call Controllo Sleep ms Next Run "Normale" Next If F = 1 Then GoTo 10 For nd = 19 To 1 Step -3 Out PP0, Mid(Vd, nd, 3) Cells(1, nd + 8).Select Run "Neretto" For m = 1 To mm If Inp(PP1) > 127 Then GoTo 9 Call Controllo Sleep ms Next Run "Normale" Out PP0, 0 Next If F = 1 Then GoTo 10 For nc = 7 To 3 Step -2 Out PP2, Mid(Vc, nc, 2) Cells(1, nc).Select Run "Neretto" For m = 1 To mm If Inp(PP1) > 127 Then GoTo 9 Call Controllo Sleep ms Next Run "Normale" Next GoTo 1 9 GoTo 19 'Out PP2, 11: Out PP0, 0 'End Sub 'Sub UP2() 10 If F = 0 Then GoTo 1 '1 accensione For nc = 1 To 7 Step 2 Out PP2, Mid(Vc2, nc, 2) Cells(1, nc).Select Run "Neretto" For m = 1 To mm If Inp(PP1) > 127 Then GoTo 19 Call Controllo Sleep ms Next Run "Normale" Next If F = 0 Then GoTo 1 For nd = 4 To 25 Step 3 Out PP0, Mid(Vd2, nd, 3) Cells(1, nd - 3 + 8).Select Run "Neretto" For m = 1 To mm If Inp(PP1) > 127 Then GoTo 19 Call Controllo Sleep ms Next Run "Normale" Next If F = 0 Then GoTo 1 '1 spengimento For nc = 3 To 9 Step 2 Out PP2, Mid(Vc1, nc, 2) Cells(1, nc - 2).Select Run "Neretto" For m = 1 To mm If Inp(PP1) > 127 Then GoTo 19 Call Controllo Sleep ms Next Run "Normale" Next If F = 0 Then GoTo 1 For nd = 1 To 22 Step 3 Out PP0, Mid(Vd1, nd, 3) Cells(1, nd + 8).Select Run "Neretto" For m = 1 To mm If Inp(PP1) > 127 Then GoTo 19 Call Controllo Sleep ms Next Run "Normale" Next If F = 0 Then GoTo 1 '2 accensione For nd = 19 To 1 Step -3 Out PP0, Mid(Vd1, nd, 3) Cells(1, nd + 8).Select Run "Neretto" For m = 1 To mm If Inp(PP1) > 127 Then GoTo 19 Call Controllo Sleep ms Next Run "Normale" Next If F = 0 Then GoTo 1 For nc = 7 To 1 Step -2 Out PP2, Mid(Vc1, nc, 2) Cells(1, nc).Select Run "Neretto" For m = 1 To mm If Inp(PP1) > 127 Then GoTo 19 Call Controllo Sleep ms Next Run "Normale" Next If F = 0 Then GoTo 1 '2 spengimento For nd = 22 To 1 Step -3 Out PP0, Mid(Vd2, nd, 3) Cells(1, nd + 8).Select Run "Neretto" For m = 1 To mm If Inp(PP1) > 127 Then GoTo 19 Call Controllo Sleep ms Next Run "Normale" Next If F = 0 Then GoTo 1 For nc = 7 To 3 Step -2 Out PP2, Mid(Vc2, nc, 2) Cells(1, nc).Select Run "Neretto" For m = 1 To mm If Inp(PP1) > 127 Then GoTo 19 Call Controllo Sleep ms Next Run "Normale" Next GoTo 10 19 Out PP2, 11: Out PP0, 0: Run "Normale": Cells(6, 33).Select End Sub Sub Neretto() With Selection.Font .FontStyle = "Grassetto" End With End Sub Sub Normale() With Selection.Font .FontStyle = "Normale" End With End Sub Sub Controllo() If Inp(PP1) = 104 Then F = 0 If Inp(PP1) = 112 Then F = 1 If Inp(PP1) = 56 And mm < 20 Then mm = mm + 0.1: Range("U3").Value = mm * 5: Range("U5").Value = 1000 / (mm * 5) If Inp(PP1) = 88 And mm > 2.1 Then mm = mm - 0.1: Range("U3").Value = mm * 5: Range("U5").Value = 1000 / (mm * 5) End Sub Sub CreaFoglio() Range("A1:AD1").Select With Selection .HorizontalAlignment = xlCenter End With Cells(1, 1).Value = Hex(PP2) & " -> C0" Cells(1, 3).Value = Hex(PP2) & " -> C1" Cells(1, 5).Value = Hex(PP2) & " -> C2" Cells(1, 7).Value = Hex(PP2) & " -> C3" Cells(1, 9).Value = Hex(PP0) & " -> D0" Cells(1, 12).Value = Hex(PP0) & " -> D1" Cells(1, 15).Value = Hex(PP0) & " -> D2" Cells(1, 18).Value = Hex(PP0) & " -> D3" Cells(1, 21).Value = Hex(PP0) & " -> D4" Cells(1, 24).Value = Hex(PP0) & " -> D5" Cells(1, 27).Value = Hex(PP0) & " -> D6" Cells(1, 30).Value = Hex(PP0) & " -> D7" For cc = 1 To 8 Step 2 Cells(1, cc).ColumnWidth = 12 Cells(1, cc + 1).ColumnWidth = 0 Next For cd = 9 To 30 Step 3 Cells(1, cd + 0).ColumnWidth = 12 Cells(1, cd + 1).ColumnWidth = 0 Cells(1, cd + 2).ColumnWidth = 0 Next Range("G3") = "Le 12 uscite: 4 del Registro Controllo" Range("G4") = "e 8 del Registro Dati, seguono l'andamento " Range("G5") = "di A1,C1,E1,G1,I1,L1,O1,R1,U1,X1,AA1,AD1" Range("R3") = "Periodo: mS" Range("R4") = " S T R U M E N T I" Range("R5") = "Frequenza: Hz" Range("AA3") = "STOP : PULSANTE S7" Range("AA4") = "AUMENTA : PULSANTE S6" Range("AA5") = "RIDUCE : PULSANTE S5" Range("R3:U5").Select Selection.Borders(xlDiagonalDown).LineStyle = xlNone Selection.Borders(xlDiagonalUp).LineStyle = xlNone With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .Weight = xlThick .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeTop) .LineStyle = xlContinuous .Weight = xlThick .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .Weight = xlThick .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .Weight = xlThick .ColorIndex = xlAutomatic End With Selection.Borders(xlInsideVertical).LineStyle = xlNone With Selection.Borders(xlInsideHorizontal) .LineStyle = xlContinuous .Weight = xlThick .ColorIndex = xlAutomatic End With Range("R3").Select With Selection.Font .Name = "Arial" .Size = 8 .Strikethrough = False .Superscript = False .Subscript = False .OutlineFont = False .Shadow = False .Underline = xlUnderlineStyleNone .ColorIndex = xlAutomatic End With Range("R5").Select With Selection.Font .Name = "Arial" .Size = 8 .Strikethrough = False .Superscript = False .Subscript = False .OutlineFont = False .Shadow = False .Underline = xlUnderlineStyleNone .ColorIndex = xlAutomatic End With ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 18#, 126#, 156.75, 53.25).Select Selection.OnAction = "UpDown" Selection.Cut Range("A2").Select ActiveSheet.Paste Selection.Characters.Text = _ " UpDown" & Chr(10) & "S4/S3 = cambia gioco luci" & Chr(10) & "Per avviare clicca Q U I " & Chr(10) & "" With Selection.Characters(Start:=1, Length:=1).Font .Name = "Arial" .FontStyle = "Normale" .Size = 16 .Strikethrough = False .Superscript = False .Subscript = False .OutlineFont = False .Shadow = False .Underline = xlUnderlineStyleNone .ColorIndex = xlAutomatic End With With Selection.Characters(Start:=2, Length:=7).Font .Name = "Arial" .FontStyle = "Grassetto Corsivo" .Size = 20 .Strikethrough = False .Superscript = False .Subscript = False .OutlineFont = False .Shadow = False .Underline = xlUnderlineStyleNone .ColorIndex = xlAutomatic End With With Selection.Characters(Start:=9, Length:=26).Font .Name = "Arial" .FontStyle = "Grassetto Corsivo" .Size = 10 .Strikethrough = False .Superscript = False .Subscript = False .OutlineFont = False .Shadow = False .Underline = xlUnderlineStyleNone .ColorIndex = xlAutomatic End With With Selection.Characters(Start:=35, Length:=28).Font .Name = "Arial" .FontStyle = "Grassetto Corsivo" .Size = 8 .Strikethrough = False .Superscript = False .Subscript = False .OutlineFont = False .Shadow = False .Underline = xlUnderlineStyleNone .ColorIndex = xlAutomatic End With With Selection.Characters(Start:=63, Length:=1).Font .Name = "Arial" .FontStyle = "Grassetto Corsivo" .Size = 10 .Strikethrough = False .Superscript = False .Subscript = False .OutlineFont = False .Shadow = False .Underline = xlUnderlineStyleNone .ColorIndex = xlAutomatic End With Range("AG6") = "aarobot" Range("AG6").Select End Sub