Keskustelu: Ohjelmointikysymykset: VB6 Save State (VB.NET)

Dim fullPath As String
Dim ClRfRep As String

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 Settings(1) As SettingType
Private Variables() As SngVarType

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
          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, ClRfRep) _
          & Chr(34) & vbCrLf
           strRet = strRet & _
          .Parent.Name & "." & .Name & ".Checked = " _
          & .Checked & vbCrLf
           strRet = strRet & _
          .Parent.Name & "." & .Name & ".Value = " _
          & Replace(str(.Value), ",", ".") & vbCrLf

       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 & _
            "Variables(" & CStr(i) & ").bool = " _
            & str(.bool) & vbCrLf & _
            "Variables(" & CStr(i) & ").dbl = " _
             & Trim(str(.dbl)) & vbCrLf & _
            "Variables(" & CStr(i) & ").int = " _
            & Trim(str(.int)) & vbCrLf & _
            "Variables(" & CStr(i) & ").lng = " _
             & Trim(str(.lng)) & vbCrLf & _
            "Variables(" & CStr(i) & ").sng = " _
            & Trim(str(.sng)) & vbCrLf & _
            "Variables(" & CStr(i) & ").str = " & _
            Chr(34) & Replace(.str, vbCrLf, ClRfRep) _
            & 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 & _
                    "Variables(" & CStr(i) & ").var = " _
                    & Trim(str(.var)) & vbCrLf
                Case False
                    SngVarStr = SngVarStr & _
                    "Variables(" & CStr(i) & ").var = " & _
                    Chr(34) & Replace(.var, vbCrLf, ClRfRep) _
                    & Chr(34) & vbCrLf
            End Select
        End With
    Next i

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

End Function

Private Sub UserForm_Activate()

    ReDim Variables(0 To 10)
    ClRfRep = Chr(34) & " & vbCrLf & _" & vbCrLf & Chr(34)
    fullPath = Environ("userprofile") _
    & "\Työpöytä\CtlSettings.Dat"
    GetSavedSettings

    Dim ChkArray As Variant
    ChkArray = Me.IsCodeInserted()

    If ChkArray(0) Then
        SetSettings
    Erase ChkArray

End Sub

Sub SaveControlSettings()

    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

    With ActiveWorkbook.VBProject. _
    VBComponents(Me.Name).CodeModule
        For i = ActiveWorkbook.VBProject. _
        VBComponents(Me.Name).CodeModule.CountOfLines _
        To 1 Step -1
            If InStr(.Lines(i, 1), _
            "Set CodeToExecute = Nothing") > 0 Then
                .ReplaceLine i, StrCode
                Exit For
            End If
        Next i
    End With

    StrCode = ""

End Sub

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

    SaveControlSettings

    Dim ChkArray As Variant
    ChkArray = Me.IsCodeInserted()

    If ChkArray(0) = True And ChkArray(1) > 0 Then

        Dim StrCode As String

        StrCode = _
        "Sub SetSettings()" & vbCrLf & _
        "   Set CodeToExecute = Nothing" & vbCrLf & _
        "End Sub"

        With ActiveWorkbook.VBProject. _
        VBComponents(Me.Name).CodeModule
            For i = ActiveWorkbook.VBProject. _
            VBComponents(Me.Name).CodeModule.CountOfLines _
            To ChkArray(1) Step -1
                .DeleteLines i
            Next i
            .InsertLines .CountOfLines + 1, StrCode
        End With
    End If

    Erase ChkArray

End Sub

Function IsCodeInserted() As Variant

    Dim CodeInserted As Boolean, spos As Long
    Dim retArray(1) As Variant

    For i = 1 To ActiveWorkbook.VBProject. _
    VBComponents(Me.Name).CodeModule.CountOfLines
        If InStr(ActiveWorkbook.VBProject. _
            VBComponents(Me.Name).CodeModule.Lines(i, 1), _
            "Sub SetSettings()") > 0 And _
            InStr(ActiveWorkbook.VBProject. _
            VBComponents(Me.Name).CodeModule.Lines( _
            i + 1, 1), Me.Name) > 0 Then
            CodeInserted = True: spos = i: Exit For
        End If
    Next i

    retArray(0) = CodeInserted: retArray(1) = spos
    IsCodeInserted = retArray(): Erase retArray

End Function

Sub SetSettings()
   Set CodeToExecute = Nothing
End Sub

Imports System
Imports System.IO
Imports System.Runtime.InteropServices
Imports System.Runtime.Serialization.Formatters.Binary

<ClassInterface(ClassInterfaceType.AutoDual)> _
<ComVisible(True)> _
<ProgId("MyBropertyBag.PropertyBag")> _
Public Class PropertyBag
   Inherits MarshalByRefObject

   <ComVisible(True)> _
   Public objCon As New Collection

   <ComVisible(True)> _
   Public Sub WriteProperty(ByVal szobjDesc As String, _
   ByVal objValue As Object)
      objCon.Add(objValue, szobjDesc)
   End Sub

   <ComVisible(True)> _
   Public Function ReadProperty(ByVal szobjDesc As String, _
   Optional ByVal ObjDefValue As Object = Nothing) As Object

      If objCon.Contains(szobjDesc) = True Then
       Return objCon.Item(szobjDesc)
      Else
       Return ObjDefValue
      End If

   End Function

   <ComVisible(True)> _
   Public Property Contents() As Object

      <ComVisible(True)> _
      Get
       Dim objMemStream As New MemoryStream
       Dim objFormatter As New BinaryFormatter
       objFormatter.Serialize(objMemStream, objCon)
       Return objMemStream.ToArray()
      End Get

      <ComVisible(True)> _
      Set(ByVal value As Object)

       Dim objMemStream As MemoryStream
       Dim objFormatter As New BinaryFormatter
       objCon.Clear()
       objMemStream = New MemoryStream(CType(value, Byte()))
       objCon = objFormatter.Deserialize(objMemStream)
      End Set

   End Property

   <ComVisible(True)> _
   Public Sub SetContents(ByVal obj As Object)
      objCon = obj
   End Sub

   <ComVisible(True)> _
   Public Sub Clear()
      objCon.Clear()
   End Sub

End Class

Imports System.Reflection
Imports System.Runtime.CompilerServices
Imports System.Runtime.InteropServices

<assembly: AssemblyTitle("MyBropertyBag")>
<assembly: AssemblyDescription("")>
<assembly: AssemblyConfiguration("")>
<assembly: AssemblyCompany("")>
<assembly: AssemblyProduct("MyBropertyBag")>
<assembly: AssemblyCopyright("")>
<assembly: AssemblyTrademark("")>
<assembly: AssemblyCulture("")>
<assembly: ComVisible(True)>
<assembly: CLSCompliant(True)>

' vaihda GUID luomalla oma GUID GuidGen apu-ohjelmalla (Registry Format)
' kopioi leikepöydälle, leikepöydältä hipsujen väliin & poista aaltosulkeet
<Assembly: Guid("D594DCBB-216E-4f4e-BD7B-83548B9EFEB3")>
<Assembly: AssemblyVersion("1.0.0.0")>
<Assembly: AssemblyFileVersion("1.0.0.0")>

Imports System
Imports System.IO
Imports System.Runtime.InteropServices
Imports System.Runtime.Serialization
Imports System.Runtime.Serialization.Formatters.Binary
Imports System.Windows.Forms

<ClassInterface(ClassInterfaceType.AutoDual)> _
<ComVisible(True)> _
<ProgId("ConvertObject.CastClass")> _
Public Class CastClass: Inherits MarshalByRefObject

   <ComVisible(True)> _
   Public Function ObjectToByteArray(ByVal _Object As Object) As Byte()

      Dim exerr As Boolean = False
      Dim _ByteArray() As Byte = Nothing
      Dim bf As BinaryFormatter = New BinaryFormatter()
      Dim ms As MemoryStream = New MemoryStream()

      Select Case _Object.GetType().ToString
         Case "System.__ComObject"
            Try
             _ByteArray = CType(_Object, Byte())
            Catch _ExceptionCom As Exception
             MsgBox(_ExceptionCom.Message.ToString)
            End Try
         Case Else
            Try
             bf.Serialize(ms, _Object)
            _ByteArray = ms.ToArray()
          Catch _Exception As Exception
              MsgBox(_Exception.Message.ToString)
          End Try
      End Select

      Return _ByteArray

   End Function

   <ComVisible(True)> _
   Public Function ByteArrayToObject(ByVal obj As Object) As Object

      Dim _ByteArray() As Byte = obj
      Dim bform As BinaryFormatter = New BinaryFormatter()
      Dim mstream As MemoryStream = New MemoryStream()
      Dim _Object As Object = Nothing

      Try
       mstream.Write(_ByteArray, 0, _ByteArray.Length)
        mstream.Seek(0, SeekOrigin.Begin)
         _Object = bform.Deserialize(mstream)
      Catch ex As Exception
       MsgBox(ex.Message.ToString)
      End Try

      Return _Object

   End Function

End Class

Imports System.Reflection
Imports System.Runtime.CompilerServices
Imports System.Runtime.InteropServices

<assembly: AssemblyTitle("ConvertTo")>
<assembly: AssemblyDescription("")>
<assembly: AssemblyConfiguration("")>
<assembly: AssemblyCompany("")>
<assembly: AssemblyProduct("ConvertTo")>
<assembly: AssemblyCopyright("Copyright 2009")>
<assembly: AssemblyTrademark("")>
<assembly: AssemblyCulture("")>
<assembly: ComVisible(True)>
<assembly: CLSCompliant(True)>

' vaihda GUID luomalla oma GUID GuidGen apu-ohjelmalla (Registry Format)
' kopioi leikepöydälle, leikepöydältä hipsujen väliin & poista aaltosulkeet
<assembly: Guid("6B3DA679-D293-4f38-BF91-9DD7ED332B49")>
<assembly: AssemblyVersion("1.0.0.0")>
<Assembly: AssemblyFileVersion("1.0.0.0")>

' VBA Projektiin referenssit:
'
' MyPropertyBag
' (C:\WINDOWS\System32\MyPropertyBag.tlb)
'
' ConvertObject
' (C:\WINDOWS\System32\ConvertObject.tlb)

' Neobase OLE interfaces & functions v8.1
' (C:\WINDOWS\System32\olelib.tlb)
' imppaa olelib.zip [linkki "http://www.elisanet.fi/nea.fi/downloads/olelib.zip"]täältä[/linkki] & pura ..\WINDOWS\System32-hakemistoon

' UserForm1:
' formille pari Image-controllia & pari nappia
Private propBag As MyBropertyBag.PropertyBag
Private conVert As ConvertObject.CastClass
Private FullPath As String
Private Sub UserForm_Activate()

   Dim BasePath As String
   Dim FileName As String
   Dim picBasePath As String
   Dim picFileName As String
   Dim picFullPath As String

   BasePath = Environ("userprofile") & "\Työpöytä"
   FileName = "arrayData.dat"

   FullPath = BasePath & "\" & FileName
   picBasePath = Environ("userprofile") & _
   "\Omat tiedostot\Omat kuvatiedostot"

   picFileName = "picture1.bmp"

   picFullPath = picBasePath & _
   "\" & picFileName
   Me.Image1.Picture = LoadPicture(picFullPath)

End Sub

Private Sub CommandButton1_Click()
   WriteTo Me
End Sub

Private Sub CommandButton2_Click()
   ReadFrom
End Sub

Private Sub WriteTo(frm As Variant)

   Dim i As Integer
   Dim ctl As Control
   Set ctl = frm.Image1
   Dim propBag As PropertyBag
   Set propBag = New PropertyBag

   If Not Image1.Picture Is Nothing Then

      If ArrayExists(ImageData()) Then Erase ImageData()
      FromImageControlToByteArray Image1.Picture
      propBag.WriteProperty "Image1", ImageData()

   End If

   If Dir(FullPath) <> "" Then
     Kill (FullPath)
     Do While Dir(FullPath) <> "": Loop
   End If

   Dim Bytes() As Byte
   Bytes = propBag.Contents
   Open FullPath For Binary As #1
   Put 1, , Bytes: Close #1
   propBag.Clear

End Sub

Private Sub ReadFrom()

   If Dir(FullPath) <> "" Then

      On Error Resume Next

      Set propBag = New PropertyBag

      If Err <> 0 Then
       Err.Clear
      End If
      On Error GoTo 0

      Dim Bytes() As Byte
      Dim strBytes As String
      Open FullPath For Binary Access Read As #1
      strBytes = Space(LOF(1))
      Get 1, , strBytes: Close #1
      Bytes = StrConv(strBytes, vbFromUnicode)
      Do While UBound(Bytes()) = 0: Loop
      Set conVert = New ConvertObject.CastClass
      Dim obj As Object
      Set obj = conVert.ByteArrayToObject(Bytes)
      propBag.SetContents obj
      Set conVert = Nothing

      If ArrayExists(ImageData()) Then Erase ImageData()
      ImageData() = propBag.ReadProperty("Image1")
      Set Image2.Picture = _
      ArrayToPicture(ImageData(), 1, UBound(ImageData))

   End If

End Sub

Private Sub UserForm_QueryClose(Cancel As _
Integer, CloseMode As Integer)
   Application.Quit
End Sub

Global ImageData() As Byte

Private Declare Function CreateStreamOnHGlobal _
Lib "ole32" (ByVal hGlobal As Long, ByVal _
fDeleteOnRelease As Long, ppstm As Any) As Long

Private Declare Function GlobalAlloc Lib "kernel32" _
(ByVal uFlags As Long, ByVal dwBytes As Long) As Long

Private Declare Function GetHGlobalFromStream Lib "ole32" _
(ByVal pstm As IStream, phglobal As Long) As Long

Private Declare Sub MoveMemory Lib "kernel32" Alias _
"RtlMoveMemory" (Dest As Any, src As Any, ByVal cb As Long)

Private Declare Function GlobalSize Lib "kernel32" _
(ByVal hMem As Long) As Long

Private Declare Function GlobalLock Lib _
"kernel32" (ByVal hMem As Long) As Long

Private Declare Function GlobalUnlock Lib _
"kernel32" (ByVal hMem As Long) As Long

Private Declare Function OleLoadPicture Lib "olepro32" _
(pStream As Any, ByVal lSize As Long, ByVal _
fRunmode As Long, riid As Any, ppvObj As Any) As Long

Private Declare Sub CopyMemory Lib "kernel32.dll" Alias _
"RtlMoveMemory" (ByRef Destination As Any, _
ByRef Source As Any, ByVal Length As Long)

Private Const PictureID = &H746C&
Private Const S_OK = 0

Private Type PictureHeader
   Magic As Long
   Size As Long
End Type


Public Function ArrayToPicture(inArray() As Byte, _
Offset As Long, Size As Long) As IPicture

   Dim o_hMem  As Long
   Dim o_lpMem  As Long
   Dim aGUID(0 To 3) As Long
   Dim IIStream As IUnknown

   aGUID(0) = &H7BF80980
   aGUID(1) = &H101ABF32
   aGUID(2) = &HAA00BB8B
   aGUID(3) = &HAB0C3000

   On Error GoTo FuncErrorHandler
   o_hMem = GlobalAlloc(&H2&, Size)

   If Not o_hMem = 0& Then
      o_lpMem = GlobalLock(o_hMem)
      If Not o_lpMem = 0& Then
         CopyMemory ByVal o_lpMem, inArray(Offset), Size
         Call GlobalUnlock(o_hMem)
         If CreateStreamOnHGlobal(o_hMem, 1&, IIStream) = 0& Then
            Call OleLoadPicture(ByVal ObjPtr(IIStream), 0&, _
            0&, aGUID(0), ArrayToPicture)
         End If
      End If
   End If

   Exit Function

FuncErrorHandler:
   Err.Clear

End Function

Public Sub FromImageControlToByteArray( _
ByVal oObj As StdPicture)

   Dim oIPS As IPersistStream
   Dim oStream As IStream, hGlobal As Long, lPtr As Long
   Dim lSize As Long, Hdr As PictureHeader
   Dim lRes As Long
   Set oIPS = oObj
   lRes = CreateStreamOnHGlobal(0, True, oStream)
   If lRes = S_OK Then
   oIPS.Save oStream, True
      If GetHGlobalFromStream(oStream, hGlobal) = S_OK Then
         lSize = GlobalSize(hGlobal)
         lPtr = GlobalLock(hGlobal)
         If lPtr Then
         lSize = lSize - Len(Hdr)
         ReDim ImageData(1 To lSize)
         MoveMemory ImageData(1), ByVal lPtr + Len(Hdr), lSize
      End If
      GlobalUnlock hGlobal
      End If
      Set oStream = Nothing
   End If

End Sub

Public Function ArrayExists(Bytes() As Byte) As Boolean

   Dim lb As Long
   On Error Resume Next

   lb = LBound(Bytes())

   If Err <> 0 Then
      Err.Clear: On Error GoTo 0
      ArrayExists = False: Exit Function
   End If
   ArrayExists = True

End Function