fivedev/harbour-core
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
e4be7fd9c052dbeca1390d11ef7f4180bcb86a8d
harbour-core/harbour/contrib/hbwin/tests/testole.prg
Viktor Szakats a623c4232f 2010-11-30 08:37 UTC+0100 Viktor Szakats (harbour.01 syenar.hu) 
* src/rtl/hbsocket.c
    ! hb_socketSetReuseAddr() changed on win platforms to use
      SO_EXCLUSIVEADDRUSE instead of SO_REUSEADDR. See http://paste.lisp.org/display/59751.
      Rough patch, maybe the logic isn't applied to the right place,
      maybe extra win version checks are required, please test it
      and patch it further if needed.

  * src/rtl/hbinet.c
    * s_inetBind() changed back to call hb_socketSetReuseAddr() also
      on win platforms.

  * contrib/hbwin/tests/testole.prg
    + Added shortcut creation example.

  * contrib/hbide/idemisc.prg
    ! Fixed HBIDE_PATHNORMALIZED() to _never_ lowercase passed
      filename. As discussed very long time ago, such behavior
      is not portable. For comparison purposes HB_FILEMATCH()
      should be used, for other purposes _no_ change should be
      done by hbide in filename casing. Ever.
      This is brute force fix only applied to low-level code.
      It will cause regressions on the higher level, which have
      to be fixed.
    ; TODO: Delete this second parameter from all calls, now
            the value is ignored.
    ; TOFIX: Review all
             HBIDE_PATHNORMALIZED() and
             HBIDE_PATHNORMALIZED( p, .T. )
             calls if they are used in comparison context and change
             caller code to use HB_FILEMATCH().
    ; TOFIX: All current code which uses LOWER()/UPPER() to
             "normalize" filename before comparison with '=='
             operator should also be changed to HB_FILEMATCH().
             (except for cases where extension is used in the
             sense of file type).
    ; TOFIX: Rest of cases where LOWER()/UPPER() is applied to
             filenames.
    ! Fixed HBIDE_PATHFILE() to never uppercase drive letter.
      It's not strictly required since all so far known systems
      supporting drive letter are case insensitive, but it's
      nevertheless not the job of hbide to reformat pathnames.

  * contrib/hbide/ideactions.prg
  * contrib/hbide/idesaveload.prg
  * contrib/hbide/ideharbourhelp.prg
  * contrib/hbide/ideeditor.prg
  * contrib/hbide/ideprojmanager.prg
  * contrib/hbide/idesources.prg
    ! Fixed some code to use HB_FILEMATCH() instead of unconditional
      uppercasing/lowercasing. Please review and finish this modification, 
      there might be more hidden places and might have overlooked anything 
      in this patch.
2010-11-30 07:46:52 +00:00

510 lines
15 KiB
Plaintext
Raw Blame History

/*
* $Id$
*/
/*
* Harbour Project source code
*
* hbole library demo/test code
*
* Copyright 2007 Enrico Maria Giordano e.m.giordano at emagsoftware.it
* Copyright 2009 Mindaugas Kavaliauskas <dbtopas at dbtopas.lt>
* Copyright 2008 Viktor Szakats (harbour.01 syenar.hu)
* Exm_CDO(), Exm_OOOpen(), Exm_CreateShortcut()
*
* www - http://harbour-project.org
*
*/
PROCEDURE Main()
LOCAL nOption
DO WHILE .T.
? ""
? "Select OLE test:"
? "1) MS Excel"
? "2) MS Word"
? "3) MS Outlook (1)"
? "4) MS Outlook (2)"
? "5) Internet Explorer"
? "6) OpenOffice Calc"
? "7) OpenOffice Writer"
? "8) OpenOffice Open"
? "9) Send mail via CDO"
? "a) Read ADODB table"
? "b) SOAP Toolkit client"
? "c) PocketSOAP client"
? "d) Internet Explorer with callback"
? "e) Create shortcut"
? "0) Quit"
? "> "
nOption := Inkey( 0 )
?? Chr( nOption )
IF nOption == Asc( "1" )
Exm_MSExcel()
ELSEIF nOption == Asc( "2" )
Exm_MSWord()
ELSEIF nOption == Asc( "3" )
Exm_MSOutlook()
ELSEIF nOption == Asc( "4" )
Exm_MSOutlook2()
ELSEIF nOption == Asc( "5" )
Exm_IExplorer()
ELSEIF nOption == Asc( "6" )
Exm_OOCalc()
ELSEIF nOption == Asc( "7" )
Exm_OOWriter()
ELSEIF nOption == Asc( "8" )
Exm_OOOpen()
ELSEIF nOption == Asc( "9" )
Exm_CDO()
ELSEIF nOption == Asc( "a" )
Exm_ADODB()
ELSEIF nOption == Asc( "b" )
Exm_SOAP()
ELSEIF nOption == Asc( "c" )
Exm_PocketSOAP()
ELSEIF nOption == Asc( "d" )
Exm_IExplorer2()
ELSEIF nOption == Asc( "e" )
Exm_CreateShortcut()
ELSEIF nOption == Asc( "0" )
EXIT
ENDIF
ENDDO
RETURN
STATIC PROCEDURE Exm_MSExcel()
LOCAL oExcel, oWorkBook, oWorkSheet, oAS
LOCAL nI, nCount
IF ( oExcel := win_oleCreateObject( "Excel.Application" ) ) != NIL
oWorkBook := oExcel:WorkBooks:Add()
// Enumerator test
FOR EACH oWorkSheet IN oWorkBook:WorkSheets
? oWorkSheet:Name
NEXT
// oWorkBook:WorkSheets is a collection
nCount := oWorkBook:WorkSheets:Count()
// Elements of collection can be accessed using :Item() method
FOR nI := 1 TO nCount
? oWorkBook:WorkSheets:Item( nI ):Name
NEXT
// OLE also allows to access collection elements by passing
// indices to :Worksheets property
FOR nI := 1 TO nCount
? oWorkBook:WorkSheets(nI):Name
NEXT
oAS := oExcel:ActiveSheet()
// Set font for all cells
oAS:Cells:Font:Name := "Arial"
oAS:Cells:Font:Size := 12
oAS:Cells( 1, 1 ):Value := "OLE from Harbour"
oAS:Cells( 1, 1 ):Font:Size := 16
// oAS:Cells( 1, 1 ) is object, but oAS:Cells( 1, 1 ):Value has value of the cell
? "Object valtype:", ValType( oAS:Cells( 1, 1 ) ), "Value:", oAS:Cells( 1, 1 ):Value
oAS:Cells( 3, 1 ):Value := "String:"
oAS:Cells( 3, 2 ):Value := "Hello, World!"
oAS:Cells( 4, 1 ):Value := "Numeric:"
oAS:Cells( 4, 2 ):Value := 1234.56
oAS:Cells( 4, 3 ):Value := oAS:Cells( 4, 2 ):Value
oAS:Cells( 4, 4 ):Value := oAS:Cells( 4, 2 ):Value
oAS:Cells( 4, 3 ):Value *= 2
oAS:Cells( 4, 2 ):Value++
oAS:Cells( 5, 1 ):Value := "Logical:"
oAS:Cells( 5, 2 ):Value := .T.
oAS:Cells( 6, 1 ):Value := "Date:"
oAS:Cells( 6, 2 ):Value := DATE()
oAS:Cells( 7, 1 ):Value := "Timestamp:"
oAS:Cells( 7, 2 ):Value := HB_DATETIME()
// Some formatting
oAS:Columns( 1 ):Font:Bold := .T.
oAS:Columns( 2 ):HorizontalAlignment := -4152 // xlRight
oAS:Columns( 1 ):AutoFit()
oAS:Columns( 2 ):AutoFit()
oAS:Columns( 3 ):AutoFit()
oAS:Columns( 4 ):AutoFit()
oAS:Cells( 3, 2 ):Font:ColorIndex := 3 // red
oAS:Range( "A1:B1" ):HorizontalAlignment := 7
oAS:Range( "A3:A7" ):Select()
oExcel:Visible := .T.
oExcel:Quit()
ELSE
? "Error: MS Excel not available. [" + win_oleErrorText()+ "]"
ENDIF
RETURN
STATIC PROCEDURE Exm_MSWord()
LOCAL oWord, oText
IF ( oWord := win_oleCreateObject( "Word.Application" ) ) != NIL
oWord:Documents:Add()
oText := oWord:Selection()
oText:Text := "OLE from Harbour" + hb_eol()
oText:Font:Name := "Arial"
oText:Font:Size := 48
oText:Font:Bold := .T.
oWord:Visible := .T.
oWord:WindowState := 1 /* Maximize */
ELSE
? "Error. MS Word not available.", win_oleErrorText()
ENDIF
RETURN
STATIC PROCEDURE Exm_MSOutlook()
LOCAL oOL, oList
IF ( oOL := win_oleCreateObject( "Outlook.Application" ) ) != NIL
oList := oOL:CreateItem( 7 /* olDistributionListItem */ )
oList:DLName := "Distribution List"
oList:Display( .F. )
ELSE
? "Error. MS Outlook not available.", win_oleErrorText()
ENDIF
RETURN
STATIC PROCEDURE Exm_MSOutlook2()
LOCAL oOL, oLista, oMail
LOCAL i
IF ( oOL := win_oleCreateObject( "Outlook.Application" ) ) != NIL
oMail := oOL:CreateItem( 0 /* olMailItem */ )
FOR i := 1 TO 10
oMail:Recipients:Add( "Contact" + LTRIM( STR( i, 2 ) ) + ;
"<contact" + LTRIM( STR( i, 2 ) ) + "@server.com>" )
NEXT
oLista := oOL:CreateItem( 7 /* olDistributionListItem */ )
oLista:DLName := "Test with distribution list"
oLista:Display( .F. )
oLista:AddMembers( oMail:Recipients )
oLista:Save()
oLista:Close( 0 )
ELSE
? "Error. MS Outlook not available.", win_oleErrorText()
ENDIF
RETURN
STATIC PROCEDURE Exm_IExplorer()
LOCAL oIE
IF ( oIE := win_oleCreateObject( "InternetExplorer.Application" ) ) != NIL
oIE:Visible := .T.
oIE:Navigate( "http://harbour-project.org" )
ELSE
? "Error. IExplorer not available.", win_oleErrorText()
ENDIF
RETURN
STATIC PROCEDURE Exm_IExplorer2()
LOCAL oIE
IF ( oIE := win_oleCreateObject( "InternetExplorer.Application" ) ) != NIL
oIE:__hSink := __AxRegisterHandler( oIE:__hObj, {|...| QOUT(...)})
oIE:Visible := .T.
oIE:Navigate( "http://harbour-project.org" )
WHILE oIE:ReadyState != 4
HB_IDLESLEEP( 0 )
ENDDO
ELSE
? "Error. IExplorer not available.", win_oleErrorText()
ENDIF
RETURN
STATIC PROCEDURE Exm_OOCalc()
LOCAL oServiceManager, oDesktop, oDoc, oSheet
IF ( oServiceManager := win_oleCreateObject( "com.sun.star.ServiceManager" ) ) != NIL
oDesktop := oServiceManager:createInstance( "com.sun.star.frame.Desktop" )
oDoc := oDesktop:loadComponentFromURL( "private:factory/scalc", "_blank", 0, {} )
oSheet := oDoc:getSheets:getByIndex(0)
oSheet:getCellRangeByName( "A1" ):setString( "OLE from Harbour" )
oSheet:getCellRangeByName( "A3" ):setString( "String:" )
oSheet:getCellRangeByName( "B3" ):setString( "Hello, World!" )
oSheet:getCellRangeByName( "A4" ):setString( "Numeric:" )
oSheet:getCellRangeByName( "B4" ):setValue( 1234.56 )
oSheet:getCellRangeByName( "A5" ):setString( "Logical:" )
oSheet:getCellRangeByName( "B5" ):setValue( .T. )
oSheet:getCellRangeByName( "B5" ):setPropertyValue( "NumberFormat", 99 ) // BOOLEAN
oSheet:getCellRangeByName( "A6" ):setString( "Date:" )
oSheet:getCellRangeByName( "B6" ):setValue( DATE() )
oSheet:getCellRangeByName( "B6" ):setPropertyValue( "NumberFormat", 36 ) // YYYY-MM-DD
oSheet:getCellRangeByName( "A7" ):setString( "Timestamp:" )
oSheet:getCellRangeByName( "B7" ):setValue( HB_DATETIME() )
oSheet:getCellRangeByName( "B7" ):setPropertyValue( "NumberFormat", 51 ) // YYYY-MM-DD HH:MM:SS
oSheet:getCellRangeByName( "A3" ):setPropertyValue( "IsCellBackgroundTransparent", .F. )
oSheet:getCellRangeByName( "A3" ):setPropertyValue( "CellBackColor", 255 ) // blue
oSheet:getCellRangeByName( "B3" ):setPropertyValue( "CharColor", 255 * 256 * 256 ) // red
ELSE
? "Error. OpenOffice not available.", win_oleErrorText()
ENDIF
RETURN
STATIC PROCEDURE Exm_OOWriter()
LOCAL oServiceManager, oDesktop, oDoc, oText, oCursor, oTable, oRow, oCell, oRows
IF ( oServiceManager := win_oleCreateObject( "com.sun.star.ServiceManager" ) ) != NIL
oDesktop := oServiceManager:createInstance( "com.sun.star.frame.Desktop" )
oDoc := oDesktop:loadComponentFromURL( "private:factory/swriter", "_blank", 0, {} )
oText := oDoc:getText
oCursor := oText:createTextCursor
oText:insertString( oCursor, "OpenOffice Writer scripting from Harbour." + CHR(10), .F. )
oText:insertString( oCursor, "This is the second line" + CHR(10), .F. )
oTable := oDoc:createInstance( "com.sun.star.text.TextTable" )
oTable:initialize( 2, 4 )
oText:insertTextContent( oCursor, oTable, .F. )
oTable:setPropertyValue( "BackTransparent", .F. )
oTable:setPropertyValue( "BackColor", ( 255 * 256 + 255 ) * 256 + 192 )
oRows := oTable:getRows
oRow := oRows:getByIndex( 0 )
oRow:setPropertyValue( "BackTransparent", .F. )
oRow:setPropertyValue( "BackColor", ( 192 * 256 + 192 ) * 256 + 128 )
oCell := oTable:getCellByName( "A1" )
oCell:insertString( oCell:createTextCursor, "Jan", .F.)
oCell := oTable:getCellByName( "B1" )
oCell:insertString( oCell:createTextCursor, "Feb", .F.)
oCell := oTable:getCellByName( "C1" )
oCell:insertString( oCell:createTextCursor, "Mar", .F.)
// I guess we can set text without cursor creation
oTable:getCellByName( "D1" ):setString("SUM")
oTable:getCellByName( "A2" ):setValue(123.12)
oTable:getCellByName( "B2" ):setValue(97.07)
oTable:getCellByName( "C2" ):setValue(106.38)
oTable:getCellByName( "D2" ):setFormula("sum <A2:C2>")
oText:insertControlCharacter( oCursor, 0 , .F. ) // PARAGRAPH_BREAK
oCursor:setPropertyValue( "CharColor", 255 )
oText:insertString( oCursor, "Good bye!", .F. )
ELSE
? "Error. OpenOffice not available.", win_oleErrorText()
ENDIF
RETURN
STATIC PROCEDURE Exm_OOOpen()
LOCAL oOO_ServiceManager
LOCAL oOO_Desktop
LOCAL oOO_PropVal01
LOCAL oOO_Doc
LOCAL cDir
IF ( oOO_ServiceManager := win_oleCreateObject( "com.sun.star.ServiceManager" ) ) != NIL
hb_FNameSplit( hb_ArgV( 0 ), @cDir )
oOO_Desktop := oOO_ServiceManager:createInstance( "com.sun.star.frame.Desktop" )
oOO_PropVal01 := oOO_ServiceManager:Bridge_GetStruct( "com.sun.star.beans.PropertyValue" )
oOO_Doc := oOO_Desktop:loadComponentFromURL( OO_ConvertToURL( hb_FNameMerge( cDir, "sample.odt" ) ), "_blank", 0, { oOO_PropVal01 } )
? "Press any key to close OpenOffice"
Inkey( 0 )
oOO_Doc:Close( .T. )
oOO_Doc := NIL
oOO_Desktop:Terminate()
oOO_Desktop := NIL
oOO_PropVal01 := NIL
ELSE
? "Error: OpenOffice not available.", win_oleErrorText()
ENDIF
RETURN
STATIC FUNCTION OO_ConvertToURL( cString )
// ; Handle UNC paths
IF !( Left( cString, 2 ) == "\\" )
cString := StrTran( cString, ":", "|" )
cString := "///" + cString
ENDIF
cString := StrTran( cString, "\", "/" )
cString := StrTran( cString, " ", "%20" )
RETURN "file:" + cString
STATIC PROCEDURE Exm_CDO()
LOCAL oCDOMsg
LOCAL oCDOConf
IF ( oCDOMsg := win_oleCreateObject( "CDO.Message" ) ) != NIL
oCDOConf := win_oleCreateObject( "CDO.Configuration" )
oCDOConf:Fields("http://schemas.microsoft.com/cdo/configuration/sendusing"):Value := 2 // ; cdoSendUsingPort
oCDOConf:Fields("http://schemas.microsoft.com/cdo/configuration/smtpserver"):Value := "localhost"
oCDOConf:Fields("http://schemas.microsoft.com/cdo/configuration/smtpserverport"):Value := 25
oCDOConf:Fields("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout"):Value := 120
oCDOConf:Fields:Update()
oCDOMsg:Configuration := oCDOConf
oCDOMsg:BodyPart:Charset := "iso-8859-2" // "iso-8859-1" "utf-8"
oCDOMsg:To := "test@localhost"
oCDOMsg:From := "sender@localhost"
oCDOMsg:Subject := "Test message"
oCDOMsg:TextBody := "Test message body"
BEGIN SEQUENCE WITH {|oErr| Break( oErr )}
oCDOMsg:Send()
RECOVER
? "Error: CDO send error.", win_oleErrorText()
END SEQUENCE
ELSE
? "Error: CDO subsystem not available (needs Windows XP or upper).", win_oleErrorText()
ENDIF
RETURN
#define adOpenForwardOnly 0
#define adOpenKeyset 1
#define adOpenDynamic 2
#define adOpenStatic 3
#define adLockReadOnly 1
#define adLockPessimistic 2
#define adLockOptimistic 3
#define adLockBatchOptimistic 4
#define adUseNone 1
#define adUseServer 2
#define adUseClient 3
STATIC PROCEDURE Exm_ADODB()
LOCAL oRs
IF ( oRs := win_oleCreateObject( "ADODB.Recordset" ) ) != NIL
oRs:Open( "SELECT * FROM test ORDER BY First", ;
"Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" + hb_DirBase() + "\..\..\hbodbc\tests\test.mdb",;
adOpenForwardOnly,;
adLockReadOnly )
DO WHILE ! oRs:EOF
? oRs:Fields( "First" ):Value
oRs:MoveNext()
ENDDO
oRs:Close()
ENDIF
RETURN
STATIC PROCEDURE Exm_SOAP()
LOCAL oSoapClient
IF ! Empty( oSoapClient := win_oleCreateObject( "MSSOAP.SoapClient30" ) )
oSoapClient:msSoapInit( "http://www.dataaccess.com/webservicesserver/textcasing.wso?WSDL" )
? oSoapClient:InvertStringCase( "lower UPPER" )
ELSE
? "Error: SOAP Toolkit 3.0 not available.", win_oleErrorText()
ENDIF
RETURN
STATIC PROCEDURE Exm_PocketSOAP()
LOCAL oEnvelope := win_oleCreateObject( "PocketSOAP.Envelope.2" )
LOCAL oHttp := win_oleCreateObject( "PocketSOAP.HTTPTransport.2" )
IF ! Empty( oEnvelope ) .OR. ! Empty( oHttp )
oEnvelope:EncodingStyle := ""
oEnvelope:SetMethod( "InvertStringCase", "http://www.dataaccess.com/webservicesserver/" )
oEnvelope:Parameters:Create( "sAString", "lower UPPER" )
oHttp:Send( "http://www.dataaccess.com/webservicesserver/textcasing.wso?WSDL", oEnvelope:Serialize() )
oEnvelope:Parse( oHttp )
? oEnvelope:Parameters:Item( 0 ):Value
ELSE
? "Error: PocketSOAP not available.", win_oleErrorText()
ENDIF
RETURN
STATIC PROCEDURE Exm_CreateShortcut()
LOCAL oShell, oSC
IF ( oShell := win_oleCreateObject( "WScript.Shell" ) ) != NIL
oSC := oShell:CreateShortcut( hb_dirBase() + hb_ps() + "testole.lnk" )
oSC:TargetPath := hb_ProgName()
oSC:WorkingDirectory := hb_DirBase()
oSC:IconLocation := hb_ProgName() + ",0"
oSC:Save()
ELSE
? "Error: Shell not available. [" + win_oleErrorText()+ "]"
ENDIF
RETURN
Reference in New Issue View Git Blame Copy Permalink