Donnerstag, 4. Mai 2017

Die Matrix ist volljährig geworden / The Matrix has come of age

Als im Jahr 1999 der erste Teil der Matrix Trilogie in den Kinos anlief war ich (wie vermutlich viele andere) von den Zeichenkaskaden des Matrixcodes fasziniert. Irgendwann baute ich mir dann zum Spaß eine ähnliche Funktionalität für den _screen des VFP Entwicklungsfensters.
Nun zum 18jährigen Jubiläum des Films habe ich den angestaubten Code heraus gekramt und abgestaubt.

Der u.a. Code kann einfach in eine .prg Datei einkopiert werden.
Solltet Ihr auf Eurem Rechner die Schriftart 'Consolas' nicht installiert haben, dann ersetzt sie in der Funktion 'SetScreen' durch eine nicht proportionale Schriftart Eurer Wahl.

* // i n i t i a l i z a t i o n
ON KEY LABEL F12 ExitLoop()
CLEAR 

PUBLIC pbExit as Boolean, paRGB( 6 )

pbExit = .F.
paRGB( 1 )    = RGB(0,60,0)
paRGB( 2 )    = RGB(0,100,0)
paRGB( 3 )    = RGB(0,140,0)
paRGB( 4 )    = RGB(0,180,0)
paRGB( 5 )    = RGB(0,220,0)
paRGB( 6 )    = RGB(0,255,0)

=SetScreen( 1 )

LOCAL    liHMax as Integer, liVMax as Integer, ;
         liCol as Integer, liLight as Integer
        
liHMax   = INT( _screen.Width / FONTMETRIC( 6 , _screen.FontName , _screen.FontSize ) )
liVMax   = INT( _screen.Height / FONTMETRIC( 1 , _screen.FontName , _screen.FontSize ) )
liCol    = 0
liLight  = RGB(180,255,180)

LOCAL    laRowFadeOut( liHMax ), laRowCurrent( liHMax )
        
STORE -6 TO laRowFadeOut
STORE -1 TO laRowCurrent

* // T H E  M A T R I X C O D E
DO WHILE pbExit = .F.
    
    * // select random column
    liCol = INT( RAND() * liHMax )
    
    * // new value for current column
    IF laRowCurrent( liCol + 1 ) > laRowFadeOut( liCol + 1 ) ;
    OR ( laRowFadeOut( liCol + 1 ) > laRowCurrent( liCol + 1 ) AND laRowFadeOut( liCol + 1 ) - laRowCurrent( liCol + 1 ) > 20 )
        laRowCurrent( liCol + 1 ) = IIF( laRowCurrent( liCol + 1 ) >= liVMax - 1 OR ROUND( RAND() * liVMax , 0 ) > liVMax - 2 , 0 , laRowCurrent( liCol + 1 ) + 1 )
        @ laRowCurrent( liCol + 1 ) - 1, liCol say GetChar()
        _screen.ForeColor = liLight
        @ laRowCurrent( liCol + 1 ) , liCol say GetChar()
        _screen.ForeColor = paRGB( ALEN( paRGB , 1 ) )
    ENDIF 

    * // fade out for current colum
    IF laRowCurrent( liCol + 1 ) > INT( liVMax / 1.5 ) ;
    OR laRowFadeOut( liCol + 1 ) >= laRowCurrent( liCol + 1 )
        @ laRowFadeOut( liCol + 1 ) , liCol say [ ]
        FOR liLoop = 1 TO ALEN( paRGB , 1 )
            _screen.ForeColor = paRGB( liLoop )
            @ laRowFadeOut( liCol + 1 ) + liLoop , liCol say GetChar()
        ENDFOR                         
        laRowFadeOut( liCol + 1 ) = IIF( laRowFadeOut( liCol + 1 ) = liVMax - 1 , ALEN( paRGB , 1 ) * -1 , laRowFadeOut( liCol + 1 ) + 1 )
        _screen.ForeColor = paRGB( ALEN( paRGB , 1 ) )
    ENDIF 
    
    * // place 10 random chars in current column
    IF laRowFadeOut( liCol + 1 ) + ALEN( paRGB , 1 ) < laRowCurrent( liCol + 1 )
        FOR liLoop = 1 TO 10
            liVal = laRowCurrent( liCol + 1 ) - ( laRowFadeOut( liCol + 1 ) + ALEN( paRGB , 1 ) )
            liRow = INT( RAND() * liVal )
            @ laRowFadeOut( liCol + 1 ) + liRow + ALEN( paRGB , 1 ) , liCol say GetChar()
        ENDFOR 
    ENDIF 
    
ENDDO 

* // c l e a n u p
=SetScreen( 2 )
ON KEY LABEL F12
RELEASE paRGB, pbExit

* // f u n c t i o n s
FUNCTION GetChar()
    RETURN CAST( ROUND( RAND() * 96 , 0 ) as C( 1 ) )
ENDFUNC 
FUNCTION ExitLoop
    pbExit = .T.
    CLEAR 
ENDPROC 
FUNCTION SetScreen
LPARAMETERS vVariante as Integer
    DO CASE 
    CASE vVariante = 1
        _screen.FontName = [OCR A EXTENDED]
        _screen.FontSize = 11
        _screen.FontBold = .F.
        _screen.BackColor = paRGB( 1 )
        _screen.ForeColor = paRGB( 6 )
    CASE vVariante = 2
        _screen.FontName = [Consolas]
        _screen.FontSize = 10
        _screen.FontBold = .F.
        _screen.BackColor = RGB(255,255,255)
        _screen.ForeColor = RGB(0,0,0)
    ENDCASE 
ENDFUNC 

Viel Spaß beim Anschauen :) und nicht vergessen: Mit F12 geht's zurück in die Realität! ;)

05.05.17 EDIT: verbesserte Version eingefügt...

Donnerstag, 22. Dezember 2016

Systeminformationen sammeln um einen eindeutigen Daumenabdruck zu generieren / Collecting Systeminformation to generate a unique fingerprint

Wenn für unsere Applikation der Bedarf besteht, dass sie nicht unkontrolliert auf ein anderes System kopierbar sein soll, dann können wir mit Hilfe der WMI (Windows Management Instrumentation) diverse Informationen aus Windows herauskitzeln.
Im Folgenden werden wir eine ID basierend auf CPU, Netzwerkadaptern und Festplatten zusammenstellen. Bei den Festplatten erfolgt eine Beschränkung auf fest installierte Datenträger. D.h. keine RAM Disks, Netzlaufwerke, CD/DVD-ROMs, SD-Karten.

Der Mustercode geht von einer verbauten CPU, mehreren Netzwerkadaptern sowie mehreren Festplatten bzw. Partitionen.

Aus dem generierten String wird im Anschluß eine Checksumme gebildet.

Um gezielt auf den Wechsel/Wegfall/Einbau einzelner Komponenten reagieren zu können kann der im Beispiel konkatenierte String auch mit Hilfe von festen Blocklängen untergliedert werden so dass bei Änderung eines einzelnen Segmentes/Blocks nicht sofort Alarm geschlagen wird.

Im Echteinsatz sollten die mit '?' beginnenden Infoausgaben natürlich auskommentiert/entfernt werden :)

CLEAR 

LOCAL lcSystemID as String
lcSystemID = []

* // retrieve CPU ID
LOCAL    lcComputerName as String, loWMI as Object, ;
        lowmiWin32Objects as Object, lowmiWin32Object as Object
lcComputerName = GETWORDNUM( SYS( 0 ) , 1 )
loWMI = GETOBJECT( [WinMgmts://] + lcComputerName )
lowmiWin32Objects = loWMI.InstancesOf( [Win32_Processor] )
FOR EACH lowmiWin32Object IN lowmiWin32Objects
    WITH lowmiWin32Object
        ? [ProcessorId: ] + TRANSFORM( .ProcessorId )
        lcSystemID = TRANSFORM( .ProcessorId )
    ENDWITH
ENDFOR
?
RELEASE lcComputerName, loWMI, lowmiWin32Objects, lowmiWin32Object

* // retrieve the MAC Address(es)
* // usually more than one (BT,WLAN,LAN,VNA)
LOCAL    lcComputerName as String, loWMIService as Object, ;
        loItems as Object, loItem as Object, lcMACAddress as String
lcComputerName = [.]
loWMIService = GETOBJECT( [winmgmts:\\] + lcComputerName + [\root\cimv2] )
loItems = loWMIService.ExecQuery( [Select * from Win32_NetworkAdapter] , , 48 )
FOR EACH loItem IN loItems
    lcMACAddress = loItem.MACAddress
    IF !ISNULL( lcMACAddress )
        ? [MAC Address: ] + loItem.MACAddress
        lcSystemID = lcSystemID + CHRTRAN( loItem.MACAddress , [:] , [] )
    ENDIF
ENDFOR
?
RELEASE lcComputerName, loWMIService, loItems, loItem, lcMACAdress

* // retrieve Volume Serial Number(s)
* // maybe more than one, even HQ NBs often have SSD and HD
LOCAL    lcComputerName as String, loWMIService as Object, ;
        loItems as Object, loItem as Object, lcVolumeSerial as String
lcComputerName = [.]
loWMIService = GETOBJECT( [winmgmts:\\] + lcComputerName + [\root\cimv2] )
loItems = loWMIService.ExecQuery( [Select * from Win32_LogicalDisk] )

FOR EACH loItem IN loItems
    lcVolumeSerial = loItem.VolumeSerialNumber
    IF !ISNULL( lcVolumeSerial ) AND CheckDriveType4( loItem.DeviceID ) = .T.
        ? [DeviceID / VSN: ] + loItem.DeviceID
        ?? [ / ] + loItem.VolumeSerialNumber
        lcSystemID = lcSystemID + loItem.VolumeSerialNumber
    ENDIF
ENDFOR
?

? [SystemID Pure:] + PADL( TRANSFORM( LEN( lcSystemID ) ) , 4 , [ ] ) + [ Chars - ] 
?? lcSystemID
? [Prüfziffer:] + SYS( 2007 , lcSystemID , 1 , 1 )
?
lcSystemID = STRCONV( lcSystemID,13)
? [SystemID MIME:] + PADL( TRANSFORM( LEN( lcSystemID ) ) , 4 , [ ] ) + [ Chars - ] 
?? lcSystemID 
? [Prüfziffer:] + SYS( 2007 , lcSystemID , 1 , 1 )

RELEASE lcComputerName, loWMIService, loItems, loItem, lcVolumeSerial, lcSystemID

FUNCTION CheckDriveType4 as Boolean
LPARAMETERS vName as String

    * // Returnvalues of GetDriveType:    
    * // 0 = DRIVE_UNKNOWN                
    * // 1 = DRIVE_NO_ROOT_DIR            
    * // 2 = DRIVE_REMOVABLE            
    * // 3 = DRIVE_FIXED                
    * // 4 = DRIVE_REMOTE                
    * // 5 = DRIVE_CDROM                
    * // 6 = DRIVE_RAMDISK                
    vName = ADDBS( EVL( vName , [C:] ) )
    
    LOCAL llReturn as Boolean
    llReturn = .F.
    
    DECLARE INTEGER GetDriveType IN kernel32 String lpszRootPathName
    IF GetDriveType( vName ) = 3
        llReturn = .T.
    ENDIF 
    
    RETURN llReturn

ENDFUNC 

SystemID und Checksumme sollten an unterschiedlichen Stellen hinterlegt sein.

Dieser Ansatz ist sicherlich nicht 'bulletproof', aber der Aufwand hält sich in Grenzen und ist somit kostengünstig umzusetzen.

Mittwoch, 7. September 2016

Objekte einer Form zur Laufzeit duplizieren / duplicating form objects at runtime

Präambel
Während der Entwicklung stehen uns für Builder die Methoden 'ReadMethod' und 'WriteMethod' zur Verfügung. Über diese können wir vorhanden Code auslesen und auch in Methoden hinein schreiben.
Zur Laufzeit steht uns dies leider nicht zur Verfügung. Aus diesem Grund müssen wir gezielt eigene von den VFP Basisklassen abgeleitete Klassen auf unseren Forms verwenden, wenn wir tatsächlich beliebige Objekte mit individuellem Methodencode duplizieren wollen.

Da dies nun geklärt ist wenden wir uns den Möglichkeiten zu, die uns zur Laufzeit zur Verfügung stehen...

Zunächst einmal erfolgt das Duplizieren eines vorhanden Objekts auf Basis seiner Klasse. D.h. wir lesen die Klasse des Quellobjektes aus und erzeugen es im Zielcontainer auf Basis dieser Vorgabe. An dieser Stelle stehen uns nun automatisch alle in einer abgeleiteten Klasse individuell ausprogrammierten Methoden zur Verfügung. Alles was nun noch zugewiesen werden muss sind die Eigenschaften des Quellobjektes. Also werden in einer Schleife die vorhandenen Eigenschaften gelesen und zugewiesen.

Mit Hilfe der Funktion AMEMBERS() ist dies ohne weiteres machbar. Allerdings müssen wir noch dafür sorgen, dass die duplizierbaren Objekte auch auf eine Duplizieranforderung reagieren. Das Codemuster beruht auf der Annahme, dass jedes dieser Objekte innerhalb seiner RightClick Methode den Aufruf der Dupliziermethode hinterlegt hat.
Lautet der Name der Methode zum Duplizieren von Objekten bspw. 'Thisform.Copy', dann sähe der Rightclick Aufruf in etwa wie folgt aus:

Thisform.Copy(This)


Innerhalb dieser Methode wird dann folgender Code eingefügt:

LPARAMETERS vObj as Object
= AMEMBERS( gaPropArray , vObj , 1 )
WITH Thisform.container2 
    * // trying to create a same named object in the target container    
    * // in case there is already a so named object, the CATCH will fire
    TRY 
        .AddObject( vObj.Name , vObj.Class )
        FOR liLoop = 1 TO ALEN( gaPropArray , 1 )
            oNewObj = EVALUATE( [Thisform.container2.] + vObj.Name )
            IF gaPropArray( liLoop , 2 ) = [Property]
                * // Some Props are write protected, so just try to assign a new value
                TRY 
                    oNewObj.&gaPropArray( liLoop , 1 ) = vObj.&gaPropArray( liLoop , 1 )
                CATCH 
                ENDTRY 
            ENDIF         
        ENDFOR 
    CATCH 
        MESSAGEBOX([Object already exists!],0+16+0,[Can't copy object])
    ENDTRY     
ENDWITH 


Um dieses Codemuster allgemein gültig zu halten sollten unsere abgeleiteten Klassen nicht nur den Aufruf der Dupliziermethode kennen wie sie in diesem Beispiel im RightClick Ereignis hinterlegt ist. Sinnvoll ist es an dieser Stelle auch, wenn wir spezielle Eigenschaften anlegen, mit denen wir später bspw. Zielcontainer, abhängige parallel positionierte Objekte (Textbox und Label gleichzeitig duplizieren), Objektnamensvergabe und Dupliziererlaubnis steuern.

Donnerstag, 21. April 2016

PDFs über das olebrowser Control anzeigen / using the olebrowser control to display PDF files

Vor vielen Jahren stand ich vor der Aufgabe, eine PDF Datei innerhalb einer VFP Maske anzuzeigen. Gelöst habe ich dies über das Einbetten des olebrowser activeX Controls. Dieses Objekt bekam als Zielseite (über .Navigate ) einfach die anzuzeigende PDF Datei hinterlegt und fertig war die Laube.

Was passiert jedoch, wenn der Anwender auf die Idee kommt, die angezeigte Datei aus der VFP Anwendung heraus zu löschen? GENAU....es poppt eine Fehlermeldung auf, dass die Datei von einer anderen Applikation gesperrt wird....

Grund ist, dass das ole Control und der darin instanziierte PDF Reader die Datei zu diesem Zeitpunkt noch anzeigen und somit diese auch sperren, was das Löschen derselbigen unmöglich macht.

Um die Datei wieder frei zu bekommen genügt es leider nicht, dem Browser Control als neue anzuzeigende Seite "about:blank" zuzuweisen. Bis das Control hinter sich aufgeräumt hat, sprich der PDF Reader geschlossen wurde, dauert es leider ein paar Millisekunden. Ein einfaches WAIT WINDOW mit timeout und anschliessendem Löschen ist keine Option, denn je nach Systemauslastung ist die Aktion in kürzerer oder in längerer Zeit durchlaufen. Um auf Nummer sicher zu gehen muss eine Warteschleife mit Abprüfung der Control Eigenschaft '.ReadyState' her.

https://msdn.microsoft.com/en-us/library/bb268229%28v=vs.85%29.aspx

Wie im obigen Link nachzulesen ist, verfügt diese Eigenschaft über fünf Zustände

    READYSTATE_UNINITIALIZED = 0
    READYSTATE_LOADING = 1
    READYSTATE_LOADED = 2
    READYSTATE_INTERACTIVE = 3
    READYSTATE_COMPLETE = 4

von denen uns an dieser Stelle nur READYSTATE_COMPLETE = 4 interessiert.

Hier nun das notwendige Codesnippet:

?DeleteFileInBrowser( [c:\temp\myFile.pdf] )

FUNCTION DeleteFileInBrowser as Boolean
LPARAMETERS vFile as String

    LOCAL llReturn as Boolean
    llReturn = .F.
    
    IF FILE( vFile )

        DECLARE Sleep IN WIN32API INTEGER

        oBrowser = Thisform.oleBrowser
        oBrowser.Navigate( [about:blank] )
        DO WHILE oBrowser.ReadyState <> 4
                Sleep(200)                
        ENDDO 

        TRY 
            DELETE FILE ( vFile )
            llReturn = .T.
        CATCH 
            * Something went wrong
            * llReturn stays .F.
        ENDTRY 
        
    ENDIF 

    RETURN llReturn
    
ENDFUNC 

Mittwoch, 11. Juli 2012

Einfaches arbeiten mit ZIP Archiven / Working with ZIP files the easy way

Das Shell.Application Objekt kennt unter anderem eine Methode namens 'CopyHere'. Diese auf den ersten Blick recht harmlos erscheinende Methode beinhaltet jedoch auch das Verarbeiten von ZIP Archiven.

Wenn wir komplette Verzeichnisse archivieren bzw. wiederherstellen wollen, dann ist dies mit CopyHere auf relative einfache Weise möglich.

Das heutige Code Beispiel besteht aus zwei kleine Routinen zum Packen und Entpacken von Verzeichnissen unter Nutzung von CopyHere:

Among other things the Shell.Application object has a method called 'CopyHere'. At first glance, it appears to be rather harmless. However it contains complete processing of ZIP archives.

So, as long as we only compute complete directories, CopyHere offers a rather easy way of doing this.

Today's code example contains two small routines for un-/packing directories via CopyHere.

ZIP
CLEAR

lcFile    = [D:\Archive\myZipArchive.zip]
lcDir    = [D:\TEMP]
?
?Zip2Archive( lcDir , lcFile )

FUNCTION zip2Archive as Boolean
     LPARAMETERS vSourceDir as String, vZipFile as String
    DECLARE Sleep IN WIN32API INTEGER
    LOCAL    llReturn as Boolean, liOption as Integer, ;
            loShellObj as Object, loInputObj as Object, loOutputObj as Object, loFile as Object
    llReturn = .F.
    loShellObj = CreateObject( [Shell.Application] )
    IF TYPE( [loShellObj] ) = [O]
        IF NOT FILE( vZipFile )
            STRTOFILE( [] , vZipFile )
        ENDIF 
        loInputObj    = loShellObj.NameSpace( vSourceDir )
        loOutputObj    = loShellObj.NameSpace( vZipFile )
        liOption    = 4 && Do not display a progress dialog box 
        IF TYPE( [loInputObj] ) = [O] AND TYPE( [loOutputObj] ) = [O]
            TRY 
                FOR EACH loFile IN loInputobj.Items
                    loTargetObjExists = loOutputObj.ParseName( loFile.Name )
                    loSourceObjExists = loInputObj.ParseName( loFile.Name )
                    IF ISNULL( loTargetObjExists )
                        loOutputObj.CopyHere( loFile , liOption )
                        SLEEP( 200 )
                    ELSE  
                        IF loOutputObj.ParseName( loFile.Name ).ModifyDate < loFile.ModifyDate
                            ?loFile.Name + [ kann aktualisiert werden]
                        ELSE 
                            ?loFile.Name + [ ist aktuell]
                        ENDIF 
                    ENDIF 
                ENDFOR 
                llReturn = .T.
            CATCH 
                * Place messagebox here
            ENDTRY
        ENDIF 
    ENDIF
    RELEASE loInputObj, loOutputObj, loShellObj, loFile
    RETURN llReturn
ENDFUNC 
Paste your text here.

UNZIP
lcFile    = [D:\Archive\myZipFile.zip]
lcDir    = [D:\TEMP]
UnzipArchive( lcFile , lcDir )

FUNCTION UnzipArchive as Boolean
    LPARAMETERS vZipFile as String, vTargetDir as String
SET STEP ON 
    LOCAL    llReturn as Boolean, liOption as Integer, ;
            loShellObj as Object, loInputObj as Object, loOutputObj as Object
    llReturn = .F.
    
    loShellObj = CreateObject( [Shell.Application] )
    IF TYPE( [loShellObj] ) = [O]
        loOutputObj    = loShellObj.NameSpace( vTargetDir )
        loInputObj    = loShellObj.NameSpace( vZipFile )
        liOption    = 4 && Do not display a progress dialog box.
        IF TYPE( [loInputObj] ) = [O] AND TYPE( [loOutputObj] ) = [O]
            TRY 
                loOutputObj.CopyHere( loInputObj.Items , liOption )
                llReturn = .T.
            CATCH 
                * Place messagebox here
            ENDTRY
        ENDIF 
    ENDIF
    RELEASE loInputObj, loOutputObj, loShellObj 
    RETURN llReturn
ENDFUNC 

Der oben stehende Code kann natürlich auf die Verarbeitung bestimmter Dateien/Dateitypen umgestellt bzw. erweitert werden.
Above code can easily be modified to work with specific files/filetypes.

Weiterführende Infos zur Arbeit mit Verzeichnissen und Archiven gibt es hier:
Additional Infos about working with directories and archives can be found here:

http://technet.microsoft.com/en-us/library/ee176625