Archive

Archive for the ‘VB6, VBA’ Category

Game of Life mit VB6 Forms

20. Januar 2011 Hinterlasse einen Kommentar

Die Konsolenversion von VB6 war ja jetzt wirklich extrem hässlich, deswegen habe ich mal was schöneres gebastelt.
So sieht das Teil aus. Leider ist nichts ungewöhnliches dran. Keine Pointer, keine HACKS, nichts… Also richtig langweilig.

image

image

 

Und der Source Code

Visual Basic
1
23
45
67
89
1011
1213
1415
1617
1819
2021
2223
2425
2627
2829
3031
3233
3435
3637
3839
4041
4243
4445
4647
4849
5051
5253
5455
5657
5859
6061
6263
6465
6667
6869
7071
7273
7475
7677
7879
8081
8283
8485
8687
8889
9091
9293
9495
9697
9899
100101
102103
104105
106107
108109
110111
112113
114115
116117
118119
120121
122123
124125
126127
128129
130131
132133
134135
136137
138139
140141
142143
144145
146147
148149
150151
152153
154155
156157
Option Explicit
 Private Declare Function WaitForSingleObject Lib "kernel32" ( _
    ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long  Private Const WELT_X As Integer = 16Private Const WELT_Y As Integer = 16
Private Const MAX_ANFANG_LEBEN As Integer = 20Private Const STABILE_MAX As Integer = 10
Private Const LEBEN_ZEICHEN As String = "X"  Private WithEvents BtnGo As CommandButton  Private Sub BtnGo_Click()      Dim x As Integer    Dim y As Integer
    Dim StabileGeneration As Integer: StabileGeneration = 0    Dim cells(0 To WELT_X - 1, 0 To WELT_Y - 1) As Byte
        ' welt nullen
    For y = 0 To WELT_Y - 1        For x = 0 To WELT_X - 1
            cells(x, y) = 0        Next
    Next        'welt mit viechern bevölkern    Randomize DateTime.Second(Time)
    Populate cells            Dim iGenerations As Integer: iGenerations = 0    Dim iOldPopulation As Integer: iOldPopulation = 0
    Dim iNewPopulation As Integer: iNewPopulation = MAX_ANFANG_LEBEN    Dim Neighbors As Integer: Neighbors = 0
        Do While StabileGeneration < STABILE_MAX
                DoEvents
        Me.Cls                                Me.Caption = "Generationen: " & iGenerations & _        " Anzahl: " & iNewPopulation
                Sleep 60
                ' stabilität checken
        If iNewPopulation > iOldPopulation - 3 And _            iNewPopulation < iOldPopulation + 3 Then
            StabileGeneration = StabileGeneration + 1        Else
            StabileGeneration = 0        End If
                iOldPopulation = iNewPopulation
        iNewPopulation = 0                For y = 1 To WELT_Y - 2            For x = 1 To WELT_X - 2
                                'Nachbarn zählen
                Neighbors = Neighbors + cells(x, y - 1)                Neighbors = Neighbors + cells(x, y + 1)
                                Neighbors = Neighbors + cells(x - 1, y)
                Neighbors = Neighbors + cells(x + 1, y)                                Neighbors = Neighbors + cells(x - 1, y - 1)                Neighbors = Neighbors + cells(x + 1, y - 1)
                                Neighbors = Neighbors + cells(x - 1, y + 1)
                Neighbors = Neighbors + cells(x + 1, y + 1)                                ' Regel anwenden                ' nr 1
                If cells(x, y) = 0 And Neighbors = 3 Then                    cells(x, y) = 1
                    Me.FillColor = vbGreen                    Me.Circle (16 * x, 16 * y), 7, vbGreen
                                'nr 2
                ElseIf Neighbors < 2 And cells(x, y) = 1 Then                    cells(x, y) = 0
                    Me.FillColor = &H808080                    Me.Circle (16 * x, 16 * y), 7, &H808080
                                    'nr 3
                ElseIf Neighbors > 1 And Neighbors < 4 And _                    cells(x, y) = 1 Then
                    Me.FillColor = vbBlue                    Me.Circle (16 * x, 16 * y), 7, vbBlue
                                    'nr 4
                ElseIf Neighbors > 3 And cells(x, y) = 1 Then                    cells(x, y) = 0
                    Me.FillColor = &H808080                    Me.Circle (16 * x, 16 * y), 7, &H808080
                                End If
                                iNewPopulation = iNewPopulation + cells(x, y)
                Neighbors = 0            Next
        Next                iGenerations = iGenerations + 1    Loop
        Me.FontTransparent = False
    If iOldPopulation = 0 Then        Me.Print "AUSGESTORBEN!"
    Else        Me.Print "Seit " & STABILE_MAX & " Generationen stabil"
    End IfEnd Sub
 Private Sub Populate(ByRef cells() As Byte)
        Dim lstart As Integer: lstart = MAX_ANFANG_LEBEN
    Dim i As Integer        Do While lstart > 0            For i = 1 To WELT_X - 2            lstart = lstart - RandomCells(cells, i, _
                CInt(Rnd() * (WELT_Y - 2)) + 1)        Next
            Loop
    End Sub
 Private Function RandomCells(ByRef cells() As Byte, _
    x As Integer, y As Integer) As Integer    If CInt(Rnd() * 1000) > 500 And cells(x, y) = 0 Then
        cells(x, y) = 1        RandomCells = 1
    Else        RandomCells = 0
    End IfEnd Function
 Private Function Sleep(ByVal millisec As Long)
  WaitForSingleObject -1, millisecEnd Function
 Private Sub Form_Load()
    Me.AutoRedraw = True    Me.ScaleMode = 3 'pixels
    Me.FillStyle = 0    Set BtnGo = Form1.Controls.Add("VB.Commandbutton", "BtnGo", Form1)
    BtnGo.Visible = True    BtnGo.Top = 10
    BtnGo.Left = Form1.ScaleWidth - BtnGo.Width - 10    BtnGo.Caption = "Los"
End Sub 
GeSHi 1.0.8.8

Ich habe mir schon eine Windows 98 SE VM gezogen für Turbo Pascal. Smiley

Kategorien:VB6, VBA Schlagwörter: , ,

Game of Life mit VB6

19. Januar 2011 Hinterlasse einen Kommentar

Game of Life mit VB6 über die Konsole. Das ist der absoluter s…. sag ich euch.

 

Visual Basic
1
23
45
67
89
1011
1213
1415
1617
1819
2021
2223
2425
2627
2829
3031
3233
3435
3637
3839
4041
4243
4445
4647
4849
5051
5253
5455
5657
5859
6061
6263
6465
6667
6869
7071
7273
7475
7677
7879
8081
8283
8485
8687
8889
9091
9293
9495
9697
9899
100101
102103
104105
106107
108109
110111
112113
114115
116117
118119
120121
122123
124125
126127
128129
130131
132133
134135
136137
138139
140141
142143
144145
146147
148149
150151
152153
154155
156157
158159
160161
162163
164165
166167
168169
170171
172173
174175
176177
178179
180181
182183
184185
186187
188189
190191
192193
194195
196197
Option Explicit
 Private Declare Function AllocConsole Lib "kernel32" () As Long
Private Declare Function GetStdHandle Lib "kernel32" ( _    ByVal nStdHandle As Long) As Long
Private Declare Function FreeConsole Lib "kernel32" () As LongPrivate Declare Function SetConsoleCtrlHandler Lib "kernel32" ( _
    ByVal HandlerRoutine As Long, ByVal Add As Long) As LongPrivate Declare Function CloseHandle Lib "kernel32" ( _
    ByVal hObject As Long) As LongPrivate Declare Function WriteConsole Lib "kernel32" Alias _
    "WriteConsoleA" (ByVal hConsoleOutput As Long, lpBuffer As Any, _    ByVal nNumberOfCharsToWrite As Long, lpNumberOfCharsWritten As Long, _
    lpReserved As Any) As LongPrivate Declare Function WaitForSingleObject Lib "kernel32" ( _
    ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long  Private hConsole As Long  Private Const WELT_X As Integer = 16Private Const WELT_Y As Integer = 16
Private Const MAX_ANFANG_LEBEN As Integer = 100Private Const STABILE_MAX As Integer = 10
Private Const LEBEN_ZEICHEN As String = "X"  Public Sub Main()        If AllocConsole Then            ' Konsole zeugs        ' =========================
        hConsole = GetStdHandle(-11&) ' Konsolenhandler holen             If hConsole = 0 Then            FreeConsole ' wenn handler null dann beenden
            Exit Sub        Else
            SetConsoleCtrlHandler AddressOf ConsoleCtrlHandler, True        End If
        ' bis hier hin        '==========================
                Dim x As Integer
        Dim y As Integer        Dim StabileGeneration As Integer: StabileGeneration = 0
        Dim CellAppearance(0 To 1) As String        CellAppearance(0) = " ": CellAppearance(1) = LEBEN_ZEICHEN
        Dim cells(0 To WELT_X - 1, 0 To WELT_Y - 1) As Byte                ' welt nullen        For y = 0 To WELT_Y - 1
            For x = 0 To WELT_X - 1                cells(x, y) = 0
            Next        Next
                'welt mit viechern bevölkern
        Randomize DateTime.Second(Time)        Populate cells
                Dim sLine(1 To WELT_X - 2) As String
        Dim sBlock As String        Dim iGenerations As Integer: iGenerations = 0
        Dim iOldPopulation As Integer: iOldPopulation = 0        Dim iNewPopulation As Integer: iNewPopulation = MAX_ANFANG_LEBEN
        Dim Neighbors As Integer: Neighbors = 0                Do While StabileGeneration < STABILE_MAX                        'Anzeigen            For y = 1 To WELT_Y - 2
                For x = 1 To WELT_X - 2                    sLine(x) = CellAppearance(cells(x, y))
                Next                sBlock = sBlock & Join(sLine, "") & "\n"
            Next            Printf sBlock, "\n\n", "Generationen: ", iGenerations, _
                " Anzahl: ", iNewPopulation, "\n\n\n\n\n\n\n\n"            Sleep 60
            sBlock = ""                        ' stabilität checken            If iNewPopulation > iOldPopulation - 2 And _
                iNewPopulation < iOldPopulation + 2 Then                StabileGeneration = StabileGeneration + 1
            Else                StabileGeneration = 0
            End If                        iOldPopulation = iNewPopulation            iNewPopulation = 0
                        For y = 1 To WELT_Y - 2
                For x = 1 To WELT_X - 2                                        'Nachbarn zählen                    Neighbors = Neighbors + cells(x, y - 1)
                    Neighbors = Neighbors + cells(x, y + 1)                                        Neighbors = Neighbors + cells(x - 1, y)                    Neighbors = Neighbors + cells(x + 1, y)
                                        Neighbors = Neighbors + cells(x - 1, y - 1)
                    Neighbors = Neighbors + cells(x + 1, y - 1)                                        Neighbors = Neighbors + cells(x - 1, y + 1)                    Neighbors = Neighbors + cells(x + 1, y + 1)
                                        ' Regel anwenden
                    ' nr 1                    If cells(x, y) = 0 And Neighbors = 3 Then
                        cells(x, y) = 1                                        'nr 2                    ElseIf Neighbors < 2 Then
                        cells(x, y) = 0                                            'nr 3                    ElseIf Neighbors > 1 And Neighbors < 4 Then
                        'lebe weiter ^^                                             'nr 4                    ElseIf Neighbors > 3 Then
                        cells(x, y) = 0                                        End If                                        iNewPopulation = iNewPopulation + cells(x, y)                    Neighbors = 0
                Next                sBlock = sBlock & Join(sLine) & "\n"
            Next                        iGenerations = iGenerations + 1        Loop
                Printf "\nSeit ", STABILE_MAX, " Generationen stabil\n"
        Sleep 2000                ' KOnsole killen        If Not (hConsole = 0) Then
            FreeConsole            CloseHandle hConsole
        End If                End If
    End Sub
 Private Sub Populate(ByRef cells() As Byte)
        Dim lstart As Integer: lstart = MAX_ANFANG_LEBEN
    Dim i As Integer        Do While lstart > 0            For i = 1 To WELT_X - 2            lstart = lstart - RandomCells(cells, i, _
                CInt(Rnd() * (WELT_Y - 2)) + 1)        Next
            Loop
    End Sub
 Private Function RandomCells(ByRef cells() As Byte, x As Integer, _
    y As Integer) As Integer    If CInt(Rnd() * 1000) > 500 And cells(x, y) = 0 Then
        cells(x, y) = 1        RandomCells = 1
    Else        RandomCells = 0
    End IfEnd Function
 Private Function Sleep(ByVal millisec As Long)
  WaitForSingleObject -1, millisecEnd Function
 Private Sub Printf(ParamArray strx() As Variant)
        Dim str As Variant
    Dim line As String        For Each str In strx        line = line & Replace$(CStr(str), "\n", vbNewLine)
    Next        WriteConsole hConsole, ByVal line, Len(line), vbNull, ByVal 0&  End Sub  Private Function ConsoleCtrlHandler(ByVal lng As Long) As Long    ConsoleCtrlHandler = 1
End Function 
GeSHi 1.0.8.8
Kategorien:VB6, VBA Schlagwörter:

Informationen aus dem Active Directory ziehen mit ADO


Manchmal sehr brauchbar in Formularen und Excel Templates. Hier ist die VB6 Version.

Public Type ActiveDirectoryUserInfo
    adFirstName As String
    adLastName As String
    adDivision As String
    adDepartment As String
    adPhoneNumber As String
    adEmailAddress As String
    adLastLogin As Date
    adLastLogoff As Date
    adAccountExpiration As Date
    adPasswordExpiration As Date
End Type

'=================================================================
' Gets information of the user from the active directory
'=================================================================
Public Function GetUserInfoAD(UserID As String) As ActiveDirectoryUserInfo

    Dim oCon As New ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim oRoot As Object
    Dim oDomain As Object
    Dim sConCommand As String
    
    Dim retval As ActiveDirectoryUserInfo
    
    On Error GoTo ErrorTrap

    'Serverless binding see
    'http://msdn.microsoft.com/en-us/library/ms677945(VS.85).aspx
    Set oRoot = GetObject("LDAP://rootDSE")
    Set oDomain = GetObject("LDAP://" & oRoot.Get("defaultNamingContext"))
    'build the command string
    sConCommand = "<" & oDomain.ADsPath & ">;" & _
                    "(&(objectCategory=person)(objectClass=user)(name=" & UserID & "));" & _
                    "adsPath;subTree"
    'init the connection
    oCon.Provider = "ADsDSOObject"
    oCon.Open "Active Directory"
    'execute the query
    Set rs = oCon.Execute(sConCommand)
    'rs = eof if nothing is found
    If Not (rs.EOF) Then
    
        'get the info
        With GetObject(rs("adsPath"))
            'errors occures if the attribute is null
            'thats why we have to skip errors
            On Error Resume Next
            retval.adAccountExpiration = CDate(.AccountExpirationDate)
            retval.adDepartment = .Department
            retval.adDivision = .Division
            retval.adEmailAddress = .EmailAddress
            retval.adFirstName = .FirstName
            retval.adLastLogin = CDate(.LastLogin)
            retval.adLastLogoff = CDate(.LastLogoff)
            retval.adLastName = .LastName
            retval.adPasswordExpiration = CDate(.PasswordExpirationDate)
            retval.adPhoneNumber = .TelephoneNumber
        
        End With
    
    End If
    
ErrorTrap:
    'we have to kill everything first
    If Not (rs Is Nothing) Then
        If rs.STATE <> 0 Then rs.Close
        Set rs = Nothing
    End If
    If Not (oCon Is Nothing) Then
        If oCon.STATE <> 0 Then oCon.Close
        Set oCon = Nothing
    End If
    
    If Not (oRoot Is Nothing) Then Set oRoot = Nothing
    If Not (oDomain Is Nothing) Then Set oDomain = Nothing
    
    'return
    GetUserInfoAD = retval

End Function
Kategorien:VB6, VBA Schlagwörter: ,