Keskustelu: Ohjelmointikysymykset: VBA: a look back at the past

'VBA Projektiin referenssi:
'Microsoft Script Control 1.1 (msscript.ocx)

'Lomakkeelle:
'7 TextBox-kontrollia *
'(set_lng, set_sng, set_dbl, set_bool, set_str, set_var)
'(TabStop & Visible arvoiksi False)
' 1 komentopainike (nappi1) + haluamiasi ohjauobjekteja...

Private Type SettingType
   Setting As String
End Type

Private Type SngVarType
   int As Integer
   lng As Long
   sng As Single
   dbl As Double
   bool As Boolean
   str As String
   var As Variant
End Type

Private Variables() As SngVarType
Private Settings(1) As SettingType
Private sc As MSScriptControl.ScriptControl
Private fullPath As String
Private CrLfRep As String

Private Sub UserForm_Activate()

   CommandButton1.Left = _
   CommandButton1.Left + 100
   CommandButton1.Top = _
   CommandButton1.Top + 100
   ReDim Variables(0 To 10) 'esim.
   CrLfRep = Chr(34) & " & vbCrLf & _" & vbCrLf & Chr(34)
   fullPath = Environ("userprofile") _
   & "\Työpöytä\CtlSettings.Dat"
   GetSavedSettings
   nappi1.Cpation = "painonappi"
   '...*** Testi
   MsgBox Variables(0).bool
   MsgBox Variables(10).int

End Sub

Private Sub nappi1_Click()
   '*** Testi...
   Variables(0).bool = Not Variables(0).bool
   Variables(10).int = _
   Abs(Variables(10).int - 10)
End Sub

Private Function GetCtlPropValues(frm As Variant) As String

   Dim strRet As String
   Dim ctl As Control
   On Error GoTo Handler

   For Each ctl In frm.Controls
      With ctl
        If InStr(.Name, "set_") = 0 Then
        strRet = strRet & _
        .Parent.Name & "." & .Name & ".Left = " & _
        Replace(str(.Left), ",", ".") & vbCrLf & _
        .Parent.Name & "." & .Name & ".Top = " & _
        Replace(str(.Top), ",", ".") & vbCrLf & _
        .Parent.Name & "." & .Name & ".Width = " & _
        Replace(str(.Width), ",", ".") & vbCrLf & _
        .Parent.Name & "." & .Name & ".Height = " & _
        Replace(str(.Height), ",", ".") & vbCrLf & _
        .Parent.Name & "." & .Name & ".Enabled = " _
        & .Enabled & vbCrLf & _
        .Parent.Name & "." & .Name & ".Visible = " _
        & .Visible & vbCrLf & _
        .Parent.Name & "." & .Name & ".ForeColor = " _
        & str(.ForeColor) & vbCrLf & _
        .Parent.Name & "." & .Name & ".BackColor = " _
        & str(.BackColor) & vbCrLf
        strRet = strRet & _
        .Parent.Name & "." & .Name & ".Caption = " _
        & Chr(34) & .Caption & Chr(34) & vbCrLf
        strRet = strRet & _
        .Parent.Name & "." & .Name & ".Text = " _
        & Chr(34) & Replace(.Text, vbCrLf, CrLfRep) _
        & Chr(34) & vbCrLf
         strRet = strRet & _
        .Parent.Name & "." & .Name & ".Checked = " _
        & .Checked & vbCrLf
         strRet = strRet & _
        .Parent.Name & "." & .Name & ".Value = " _
        & Replace(str(.Value), ",", ".") & vbCrLf
        End If
      End With

   Next

   GetCtlPropValues = Replace(strRet, "  ", " "): strRet = ""
   Exit Function

Handler:
   Err.Clear
   Resume Next

End Function

Private Function GetSngVariables() As String

   Dim SngVarStr As String

   For i = LBound(Variables) To UBound(Variables)
      With Variables(i)
         SngVarStr = SngVarStr & _
         "set_bool.Value = " _
         & str(.bool) & vbCrLf & _
         "set_dbl.Value = " _
          & Trim(str(.dbl)) & vbCrLf & _
         "set_int.Value = " _
         & Trim(str(.int)) & vbCrLf & _
         "set_lng.Value = " _
          & Trim(str(.lng)) & vbCrLf & _
         "set_sng.Value = " _
         & Trim(str(.sng)) & vbCrLf & _
         "set_str.Value = " & _
         Chr(34) & Replace(.str, vbCrLf, CrLfRep) _
         & Chr(34) & vbCrLf

         Dim IsNum As Boolean
         IsNum = True

         For j = 1 To Len(.var)
           If Not IsNumeric(Mid(.var, j, 1)) Then
             IsNum = False: Exit For
           End If
         Next j

         Select Case IsNum
            Case True
               SngVarStr = SngVarStr & _
               "set_var.Value = " _
               & Trim(str(.var)) & vbCrLf
            Case False
               SngVarStr = SngVarStr & _
               "set_var.Value = " & Chr(34) _
               & Replace(.var, vbCrLf, CrLfRep) _
               & Chr(34) & vbCrLf
         End Select
      End With
   Next i

   GetSngVariables = _
   Replace(SngVarStr, "  ", " ")
   SngVarStr = ""

End Function

Private Sub set_bool_Change()

   If set_bool.Value <> "" Then
      Static i As Integer
      Variables(i).bool = set_bool.Value
      i = i + 1
      set_bool.Value = ""
   End If

End Sub

Private Sub set_dbl_Change()

   Static i As Integer
   If set_dbl.Value <> "" Then
      Variables(i).dbl = set_dbl.Value
      i = i + 1
      set_dbl.Value = ""
   End If

End Sub

Private Sub set_int_Change()

   Static i As Integer
   If set_int.Value <> "" Then
      Variables(i).int = set_int.Value
      i = i + 1
      set_int.Value = ""
   End If

End Sub

Private Sub set_lng_Change()

   Static i As Integer
   If set_lng.Value <> "" Then
      Variables(i).lng = set_lng.Value
      i = i + 1
      set_lng.Value = ""
   End If

End Sub

Private Sub set_sng_Change()

   Static i As Integer
   If set_sng.Value <> "" Then
      Variables(i).sng = set_sng.Value
      i = i + 1
      set_sng.Value = ""
   End If

End Sub

Private Sub set_str_Change()

   Static i As Integer
   If set_str.Value <> "" Then
      Variables(i).str = set_str.Value
      i = i + 1
      set_str.Value = ""
   End If

End Sub

Private Sub set_var_Change()

   Static i As Integer
   If set_var.Value <> "" Then
      Variables(i).var = set_var.Value
      i = i + 1
      set_var.Value = ""
   End If

End Sub

Sub SaveSettings()

   Settings(0).Setting = GetCtlPropValues(Me)
   Settings(1).Setting = GetSngVariables()

   For i = 0 To 1
      If Settings(i).Setting <> "" Then
         Settings(i).Setting = _
         Left(Settings(i).Setting, _
         Len(Settings(i).Setting) - 2)
      End If
   Next i

   Open fullPath For Output As 1#
   For i = LBound(Settings) To UBound(Settings)
      Print #1, Settings(i).Setting
   Next i: Close #1

End Sub

Sub GetSavedSettings()

   Dim StrCode As String

   If Dir(fullPath) = "" Then
      Exit Sub
   End If

   Open fullPath For Input As #1
   StrCode = Input$(LOF(1), 1)
   Close #1

   Dim ctlPropValues As String

   ctlPropValues = Left(StrCode, _
   InStr(StrCode, "set_") - 1)

   Dim varValues As String
   varValues = Replace(StrCode, ctlPropValues, "")

   Set sc = New MSScriptControl.ScriptControl
   With sc
     .Language = "VBScript"
     .AddObject "UserForm1", Me, True
     .AllowUI = True
     .AddCode ctlPropValues
     .ExecuteStatement (ctlPropValues)
     .ExecuteStatement (varValues)
     .Reset
   End With

   Set sc = Nothing: StrCode = ""

End Sub

Private Sub UserForm_QueryClose( _
Cancel As Integer, CloseMode As Integer)

   SaveSettings
   Application.Quit

End Sub