Memo alanların Excel e aktarılması?

CLOSE ALL

CLEAR ALL

 

lcFieldString = ''

lcMemo = ''

 

USE GETFILE('dbf', 'Select DBF') && Prompts for table to be used.

 

lnFieldCount = AFIELDS(laGetFields) && Builds array of fields from the

                                    && selected table.

 

*!* Prompt for Output file and use Low-Level functions

*!* to create it.

lcTextFile = FCREATE(GETFILE('txt', 'Select Text'))

 

*!* Starts scanning the table and converts the fields

*!* values according to their types **

SCAN

   WAIT WINDOW STR(RECNO()) + ' Of ' + STR(RECCOUNT()) NOWAIT

  

   FOR lnCount = 1 TO lnFieldCount

      lcType = laGetFields(lnCount, 2)

 

      IF lcType # 'G' && Don't try to turn a general field into a string

         lcString = EVALUATE(laGetFields(lnCount, 1))

      EndIf

      

      DO CASE

         CASE lcType = 'M' && Process the Memo Fields

            lnMemoLines = MEMLINES(EVALUATE(laGetFields(lnCount,1)))

            FOR lnLoop = 1 TO lnMemoLines

               IF lnLoop < lnMemoLines

                  lcMemo = lcMemo + ;

                     ALLTRIM(MLINE(EVALUATE(laGetFields(lnCount, 1)), ;

                                   lnLoop)) + ' '

               ELSE

                  lcMemo = lcMemo + ;

                     ALLTRIM(MLINE(EVALUATE(laGetFields(lnCount, 1)), ;

                                   lnLoop))

               ENDif

            ENDfor

           

            lcString = lcMemo

            lcMemo = ''

         CASE lcType = 'G' && Process the General Fields

            lcString = 'Gen'

         CASE lcType = 'D' && Process the Date Fields

            lcString = DTOC(lcString)

         CASE lcType = 'T' && Process the DateTime Fields

            lcString = TTOC(lcString)

         CASE lcType = 'N' && Process the Numeric Fields

            lcString = STR(lcString, LEN(STR(lcString)), 2)

         CASE lcType = 'I' && Process the Integer Fields

            lcString = STR(lcString)

         CASE lcType = 'L' && Process the Logical Fields

            IF lcString = .T.

               lcString = 'T'

            ELSE

               lcString = 'F'

            ENDif

      ENDcase

     

      IF lnCount < lnFieldCount && Determines if the last field was

                                && processed and sets the closing quote.

         lcFieldString = lcFieldString + '"' + lcString + '"' + ','

      ELSE

         lcFieldString = lcFieldString + '"' + lcString + '"'

      ENDif

   ENDfor

 

   FPUTS(lcTextFile, lcFieldString) && Writes string to the text file.

   lcFieldString = ''

ENDscan

 

FCLOSE(lcTextFile)

 

CLOSE All

CLEAR All

WAIT WINDOW 'Text File Creation Completed' NOWAIT

*Not : xlconstants.h (Excel header file) yoksa Excel'i ac, Alt+f11, f2 oject browseri getiriyor. Oradan asagida kullanilan excel sabitlerini bulup degerlerini yerine koyabilirsin (xl ile baslayanlar).

 

Use memotable

 

=Table2ClipBoard()

#include "excel-all.h"

oExcel = createobject("Excel.Application")

With oExcel

   .Workbooks.Add

   .visible = .t.

   With .ActiveWorkbook.ActiveSheet

      .Paste

      .Range('A1').CurrentRegion.Replace("PMARK",""+chr(10)+"",xlPart,xlByRows, .F.)

   Endwith

   With .Selection

      .ColumnWidth = 50 && Increase width for memo

      .HorizontalAlignment = xlGeneral

*      .VerticalAlignment = xlTop

      .WrapText = .T.

   Endwith

Endwith

 

 

Function Table2ClipBoard

lcTempFileName = "X"+sys(2015)+".tmp"

handle = fcreate(lcTempFileName)   && Create a temp file

#Define TABULATE chr(9)

#Define NL chr(13)

 

For ix = 1 to fcount()

   =fwrite(handle, field(ix))

   If ix < fcount()

      =fwrite(handle, TABULATE)

   Endif

Endfor

=fwrite(handle, NL)

Scan      && Start scan..endscan

   For ix = 1 to fcount()   && Write field values

      =fwrite(handle, typeconvert(ix) )

      If ix < fcount()

         =fwrite(handle, TABULATE)

      Endif

   Endfor

   =fwrite(handle, NL)

Endscan

lnSize=fseek(handle,0,2)

=fseek(handle,0,0)

_Cliptext = fread(handle, lnSize)  && Read file to clipboard

=fclose(handle)

Erase (lcTempFileName)

 

Function typeconvert

Lparameters tnField

lcType = type(field(ix))

If lcType = "G"

   lcField = field(ix)

*   Return '' && VFP5 and 3

   Return transform(&lcField) && VFP6 and up

Endif

luValue = eval(field(ix))

Do case

Case lcType = "D"

   lcValue = dtoc(luValue)

Case lcType = "T"

   lcValue = ttoc(luValue)

Case lcType $ "NY"

   lcValue = padl(luValue,20," ")

Case lcType = "L"

   lcValue = iif(luValue,"Yes","No")

Case lcType $ "M" && Replace paragraph marks with "PMARK"

   lcValue = strtran(luValue, chr(13)+chr(10), "PMARK")

Case lcType $ "C"

   lcValue = luValue

Otherwise

   lcValue = ""

Endcase

Return alltrim(lcValue)