REPORT  Z_SELECT2                                                   .
INCLUDE ole2incl.
data:
connection type ole2_object,
rs type ole2_object,
connectionstring(500),
state type i,
sql(1000) ,
eof.
data : time_begin like sy-uzeit,
      time_end like sy-uzeit.

*примеры строк коннекта
ConnectionString = 'Provider=vfpoledb;Data Source=c:\1sblob.dbf;Exclusive=No;BackgroundFetch=Yes;Collate=Machine;Null=Yes;Deleted=Yes;'.





sql = 'SELECT block as a1 From 1sblob '.


create object connection 'adodb.connection'.
if sy-subrc ne 0.
PERFORM end_program.
endif.

set property of connection 'ConnectionString' = ConnectionString.
if sy-subrc ne 0.
PERFORM end_program.
endif.


call method of connection 'Open'.
if sy-subrc ne 0.
PERFORM end_program.
endif.

create object rs 'adodb.recordset'.
if sy-subrc ne 0.
PERFORM end_program.
endif.

get property of rs 'State' = state.
if sy-subrc ne 0.
PERFORM end_program.
else.
if state = 1.
call method of rs 'Close'.
if sy-subrc ne 0.
PERFORM end_program.
endif.
endif.
endif.

set property of rs 'CursorType' = 1. "3
*gdbExtDBConcurAuto
* Автоматический подбор режима.
*
*gdbExtDBConcurLock
* Блокировка модифицированное записи в наборе записей
*
*gdbExtDBConcurReadOnly
* Курсор только на чтение
*
*gdbExtDBConcurRowVer
* Оптимистическая стратегия, сравнение версий записей
*
*gdbExtDBConcurValues
* Оптимистическая стратегия, сравнение полей



if sy-subrc ne 0.
PERFORM end_program.
endif.

set property of rs 'LockType' = 1. "1
*1. gdbLckNoLock - блокировка отсутствует
*
*2. gdbLckSLock  - блокировка совместного доступа
*
*3. gdbLckXLock  - эксклюзивная блокировка
*
*4. gdbLckClosed - сеанс закрыл ГБД/общую библиотеку
*
*5. gdbLckTerminated - сеанс принудительно завершен


if sy-subrc ne 0.
PERFORM end_program.
endif.

set property of rs 'CursorLocation' = 2. "2
if sy-subrc ne 0.
PERFORM end_program.
endif.

set property of rs 'ActiveConnection' = connection.
if sy-subrc ne 0.
PERFORM end_program.
endif.




call method of rs 'Open' exporting #1 = sql.

if sy-subrc ne 0.
PERFORM end_program.

endif.

call method of rs 'MoveFirst' .
if sy-subrc ne 0.
PERFORM end_program.
endif.
DATA:
a1 type ole2_object,
a2 type ole2_object.

DATA: BEGIN OF itab OCCURS 100,
a1(100) TYPE C,
a2(100) TYPE C.
DATA: END OF itab.


get property of rs 'EOF' = eof.
if sy-subrc ne 0.
PERFORM end_program.
endif.

call method of rs 'Fields' = a1
exporting #1 = 'a1'.

if sy-subrc ne 0.
PERFORM end_program.
endif.



WHILE eof = '0'.

get property of a1 'Value' = itab-a1.
write itab-a1.

if sy-subrc ne 0.
PERFORM end_program.
endif.



call method of rs 'MoveNext'.
if sy-subrc ne 0.
PERFORM end_program.
endif.

get property of rs 'EOF' = eof.
if sy-subrc ne 0.
PERFORM end_program.
endif.
APPEND itab.
ENDWHILE.

call method of rs 'Close'.
call method of connection 'Close'.

form end_program.

endform.

FORM upload_dbf_file
  TABLES   pt_file
  USING    p_fpath.

  DATA l_fpath  TYPE string.

  TYPES: BEGIN OF ty_data
    , row(1024) TYPE x
    , END OF ty_data.

  DATA lt_data  TYPE STANDARD TABLE OF ty_data.
  DATA lwa_data  LIKE LINE OF lt_data.

  l_fpath = p_fpath.


  CALL METHOD cl_gui_frontend_services=>gui_upload
    EXPORTING
      filename                = l_fpath
      filetype                = 'BIN'
    CHANGING
      data_tab                = lt_data
    EXCEPTIONS
      file_open_error         = 1
      file_read_error         = 2
      no_batch                = 3
      gui_refuse_filetransfer = 4
      invalid_type            = 5
      no_authority            = 6
      unknown_error           = 7
      bad_data_format         = 8
      header_not_allowed      = 9
      separator_not_allowed   = 10
      header_too_long         = 11
      unknown_dp_error        = 12
      access_denied           = 13
      dp_out_of_memory        = 14
      disk_full               = 15
      dp_timeout              = 16
      not_supported_by_gui    = 17
      error_no_gui            = 18.

  IF sy-subrc NE 0.
    MESSAGE ID sy-msgid TYPE sy-msgty NUMBER sy-msgno
          WITH sy-msgv1 sy-msgv2 sy-msgv3 sy-msgv4.
  ENDIF.

* Parse Dbf File Into Internal Table
  PERFORM read_dbf
    TABLES lt_data
           pt_file.



ENDFORM.                    "upload_dbf_file
*&---------------------------------------------------------------------*
*&      Form  read_dbf
*&---------------------------------------------------------------------*
*       text
*----------------------------------------------------------------------*
*  -->  p1        text
*  <--  p2        text
*----------------------------------------------------------------------*
FORM read_dbf
  TABLES pt_xdata
         pt_dbf.

* Dbf Header
  DATA: BEGIN OF ls_dbf_head
    , date              LIKE sy-datum
    , rows              TYPE int4
    , start_offset      TYPE int2
    , row_len           TYPE int2
    , END OF ls_dbf_head.

* Fields Catalog
  DATA: BEGIN OF lt_dbf_fields  OCCURS 0
    , name              TYPE char10
    , type              TYPE c
    , pos               TYPE int4
    , len               TYPE int1
    , digits            TYPE int1
    , END OF lt_dbf_fields.

  DATA l_xdbf          TYPE xstring.
  DATA l_xstring       TYPE xstring.
  DATA l_xfield        TYPE xstring.
  DATA l_xrow          TYPE xstring.
  DATA l_len           TYPE i.
  DATA l_fields_len    TYPE i.
  DATA l_offset        TYPE i.
  DATA l_field_offset  TYPE i.

  FIELD-SYMBOLS <fs_x>       TYPE ANY.
  FIELD-SYMBOLS <fs_any>     TYPE ANY.
  FIELD-SYMBOLS <fs_value>   TYPE ANY.


* All Table into X string
  CLEAR l_xdbf.

  LOOP AT pt_xdata ASSIGNING <fs_any>.
    ASSIGN COMPONENT 1 OF STRUCTURE <fs_any> TO <fs_x>.
    CHECK sy-subrc EQ 0.

    l_xstring = <fs_x>.
    CONCATENATE l_xdbf l_xstring INTO l_xdbf IN BYTE MODE.
  ENDLOOP.

* Fill Dbf Header
  CLEAR ls_dbf_head.


* Count of Rows
  l_xstring = l_xdbf+4(4).
  PERFORM convert_from_x
    USING     l_xstring
    CHANGING  ls_dbf_head-rows.

* Start Offset
  l_xstring = l_xdbf+8(2).
  PERFORM convert_from_x
    USING     l_xstring
    CHANGING  ls_dbf_head-start_offset.

* Row Len
  l_xstring = l_xdbf+10(2).
  PERFORM convert_from_x
    USING     l_xstring
    CHANGING  ls_dbf_head-row_len.


* Fill Dbf Fields
  REFRESH lt_dbf_fields[].

  l_offset = 32.

  l_fields_len = ls_dbf_head-start_offset - 1.

  WHILE l_offset LT l_fields_len.

    l_xfield = l_xdbf+l_offset(32).
    CLEAR lt_dbf_fields.

*   Field Name
    l_xstring = l_xfield(10).
    PERFORM convert_from_x
      USING     l_xstring
      CHANGING  lt_dbf_fields-name.

*   Field Type
    l_xstring = l_xfield+11(1).
    PERFORM convert_from_x
      USING     l_xstring
      CHANGING  lt_dbf_fields-type.

*   Field Position
    l_xstring = l_xfield+12(4).
    PERFORM convert_from_x
      USING     l_xstring
      CHANGING  lt_dbf_fields-pos.

*   Field Length
    l_xstring = l_xfield+16(1).
    PERFORM convert_from_x
      USING     l_xstring
      CHANGING  lt_dbf_fields-len.

*   Digits
    l_xstring = l_xfield+17(1).
    PERFORM convert_from_x
      USING     l_xstring
      CHANGING  lt_dbf_fields-digits.

    APPEND lt_dbf_fields.
    ADD 32 TO l_offset.

  ENDWHILE.

* Fill Data
  REFRESH pt_dbf[].

  l_offset = ls_dbf_head-start_offset.

  DO ls_dbf_head-rows TIMES.
    l_xrow = l_xdbf+l_offset(ls_dbf_head-row_len).
    CLEAR pt_dbf.

*   Not Deleted
    CHECK l_xrow(1) EQ '20'.

    l_field_offset = 1.

*   For All Fields
    LOOP AT lt_dbf_fields.

      ASSIGN COMPONENT lt_dbf_fields-name OF STRUCTURE pt_dbf TO <fs_value>.
      CHECK sy-subrc EQ 0.

      l_len     = lt_dbf_fields-len.
      l_xstring = l_xrow+l_field_offset(l_len).

*     Read Value
      PERFORM convert_from_x
        USING     l_xstring
        CHANGING  <fs_value>.

      ADD l_len TO l_field_offset.
    ENDLOOP.

    ADD l_field_offset TO l_offset.

    APPEND pt_dbf.
  ENDDO.

ENDFORM.                    " read_dbf
*&---------------------------------------------------------------------*
*&      Form  convert_from_x
*&---------------------------------------------------------------------*
*       text
*----------------------------------------------------------------------*
*      -->P_L_XDBF+4(4)  text
*      <--P_LS_DBF_HEAD_ROWS  text
*----------------------------------------------------------------------*
FORM convert_from_x  USING    p_xstring TYPE xstring
                     CHANGING p_value.

  DATA l_type        TYPE c.
  DATA l_x00         TYPE x VALUE '00'.
  DATA l_x20         TYPE x VALUE '20'.

* Convert From XString
  DATA lc_conv     TYPE REF TO cl_abap_conv_in_ce.
  DATA l_len       TYPE i.
  DATA l_xstring   TYPE xstring.

  l_xstring = p_xstring.

  DESCRIBE FIELD p_value TYPE l_type.

  IF l_type CA 'Cg'.
    REPLACE ALL OCCURRENCES OF l_x00 IN l_xstring WITH l_x20  IN BYTE MODE.
  ENDIF.


  CALL METHOD cl_abap_conv_in_ce=>create
    EXPORTING
      input       = l_xstring
      encoding    = '1504'
      replacement = space
      ignore_cerr = abap_true
    RECEIVING
      conv        = lc_conv.

  TRY.
      CALL METHOD lc_conv->read
        IMPORTING
          data = p_value
          len  = l_len.

*   Should ignore errors in code conversions
    CATCH cx_sy_conversion_codepage.
    CATCH cx_sy_codepage_converter_init.
    CATCH cx_parameter_invalid_type.
    CATCH cx_parameter_invalid_range.
  ENDTRY.

ENDFORM.                    " convert_from_x

024630     DO ls_dbf_head-rows TIMES.
     >       l_xrow = l_xdbf+l_offset(ls_dbf_head-row_len).
024650       CLEAR pt_dbf.

  CALL METHOD cl_abap_conv_in_ce=>create
    EXPORTING
      input       = l_xstring
      encoding    = '1504'
      endian      = 'L'
      replacement = space
      ignore_cerr = abap_true
    RECEIVING
      conv        = lc_conv.

ASSIGN COMPONENT lt_dbf_fields-name OF STRUCTURE pt_dbf TO <fs_value>.

ASSIGN COMPONENT SY-TABIX OF STRUCTURE pt_dbf TO <fs_value>.