KGF_dll - nouvelles versions

' test_SQLite3.bas

label init, open, close, reset, change, exit
label sample1, sample2, sample3, sample4
label start, exec, commit, rollback, fill, fillgrid, tables, columns
label clickgrid, maj

dim res%, base$, SQL%, xNbrRecords%, x%, sOtherID$, sName$, sNumber$
dim p%, sNotes$, sSQL$, RowCount%, TestTable$, i%, j%, s$, y%, id$, champ$
  TestTable$ = "TestTable"

full_space 0 : on_close 0,exit

main_menu 1
  sub_menu 11 : parent 11,1 : caption 11,"File"
    sub_menu 111 : parent 111,11 : caption 111,"Initialize SQLite3" : on_click 111,init
    sub_menu 112 : parent 112,11 : caption 112,"Open SQLite3" : on_click 112,open
    sub_menu 113 : parent 113,11 : caption 113,"Close SQLite3" : on_click 113,close
    sub_menu 114 : parent 114,11 : caption 114,"Reset SQLite3" : on_click 114,reset
    sub_menu 115 : parent 115,11 : caption 115,"-"
    sub_menu 116 : parent 116,11 : caption 116,"Change version" : on_click 116,change
    sub_menu 117 : parent 117,11 : caption 117,"-"
    sub_menu 118 : parent 118,11 : caption 118,"Exit" : on_click 118,exit
  sub_menu 12 : parent 12,1 : caption 12,"Sample scripts SQL"
    sub_menu 121 : parent 121,12 : caption 121,"Create sample table" : on_click 121,sample1
    sub_menu 122 : parent 122,12 : caption 122,"Delete sample table" : on_click 122,sample2
    sub_menu 123 : parent 123,12 : caption 123,"Delete records with selection" : on_click 123,sample3
    sub_menu 124 : parent 124,12 : caption 124,"Empty sample table" : on_click 124,sample4
  sub_menu 13 : parent 13,1 : caption 13,"Execute scripts SQL"
    sub_menu 131 : parent 131,13 : caption 131,"Start transaction" : on_click 131,start
    sub_menu 132 : parent 132,13 : caption 132,"Execute script from memo" : on_click 132,exec
    sub_menu 133 : parent 133,13 : caption 133,"Commit transaction" : on_click 133,commit
    sub_menu 134 : parent 134,13 : caption 134,"Rollback transaction" : on_click 134,rollback
    sub_menu 135 : parent 135,13 : caption 135,"-"
    sub_menu 136 : parent 136,13 : caption 136,"Fill data base" : on_click 136,fill
    sub_menu 137 : parent 137,13 : caption 137,"Fill grid from data base" : on_click 137,fillgrid
    sub_menu 138 : parent 138,13 : caption 138,"Get table names in data base" : on_click 138,tables
    sub_menu 139 : parent 139,13 : caption 139,"Get column names in table 'Critère'" : on_click 139,columns
   

alpha 1000 : top 1000,10 : left 1000,10 : caption 1000,"Réponse de SQLite3:"
memo 1001 : top 1001,30 : left 1001,10 : width 1001,500 : height 1001,300 : bar_both 1001

alpha 1010 : top 1010,350 : left 1010,10 : caption 1010,"Script SQL:"
memo 1011 : top 1011,370 : left 1011,10 : width 1011,500 : height 1011,300 : bar_both 1011

progress_bar 1020 : top 1020,680 : left 1020,10 : width 1020,500

alpha 1030 : top 1030,10 : left 1030,540 : caption 1030,"Critère:"
edit 1031 : top 1031,10 : left 1031,600 : width 1031,300
  text 1031,"A%"
alpha 1032 : top 1032,40 : left 1032,540 : caption 1032,"Paramètre:"
edit 1033 : top 1033,40 : left 1033,600 : width 1033,300
  text 1033,"ORDER BY OtherID ASC"
grid 1034 : top 1034,70 : left 1034,540 : width 1034,500 : height 1034,300
  grid_column 1034,5 : grid_row 1034,500 : grid_column_fixed 1034,0
  grid_one_column_width 1034,1,40
  grid_one_column_width 1034,2,60
  grid_one_column_width 1034,3,80
  grid_one_column_width 1034,4,100
  grid_one_column_width 1034,5,200
  grid_write 1034,1,1,"ID"
  grid_write 1034,1,2,"OtherID"
  grid_write 1034,1,3,"Name"
  grid_write 1034,1,4,"Number"
  grid_write 1034,1,5,"Notes"
  on_click 1034,clickgrid
alpha 1035 : top 1035,390 : left 1035,540 : caption 1035,"Ligne:"
alpha 1036 : top 1036,390 : left 1036,570
alpha 1037 : top 1037,390 : left 1037,600 : caption 1037,"Colonne:"
alpha 1038 : top 1038,390 : left 1038,640
alpha 1039 : top 1039,390 : left 1039,680 : caption 1039,"Valeur:"
edit 1040 : top 1040,390 : left 1040,720 : width 1040,200
button 1041 : top 1041,390 : left 1041,950 : caption 1041,"Mise à jour" : on_click 1041,maj

dll_on "KGF.dll"

end

sub ClearGrid()
dim_local r11%,c1%
  grid_row 1034,1
end_sub

init:
  res% = dll_call0("InitializeSQLite3")
  item_add 1001,"init "+str$(res%)
  res% = dll_call1("GetSQLite3Version",handle(1011))
  item_add 1001,"  version "+str$(res%)
  return

open:
  base$ = "MonTestSQLite2.db"
  SQL% = dll_call2("OpenSQLite3",adr(base$),handle(1001))
  item_add 1001,"open "+str$(SQL%)
 
  ' récupérer le nombre de lignes de la réponse
  RowCount% = dll_call2("GetSQLite3RowCount",SQL%,adr(TestTable$))
  item_add 1001,"  "+str$(rowcount%)+" Lignes dans table "+TestTable$
  return

close:
  SQL% = dll_call1("CloseSQLite3",SQL%)
  item_add 1001,"close "+str$(SQL%)
  return
 
reset:
  res% = dll_call0("ResetSQLite3")
  clear 1001
  item_add 1001,"reset "+str$(res%)
  return
 
change:
  s$ = message_input$("Select SQLite3 version","SQLite3 dll name:","SQLite367")
  res% = dll_call1("SelectAlternativeSQLite3Version",adr(s$))
  return
   
exit:
  SQL% = dll_call1("CloseSQLite3",SQL%)
  res% = dll_call0("ResetSQLite3")
  terminate
 
 
 
sample1:          : ' création d'une table de démo
  clear 1011
  item_add 1011,"CREATE TABLE "+TestTable$+" ([ID] INTEGER PRIMARY KEY,[OtherID] INTEGER NULL,"
  item_add 1011,"[Name] VARCHAR (255),[Number] FLOAT, [notes] BLOB);" 
  return 
 
sample2:          : ' supprimer une table de démo
  clear 1011
  item_add 1011,"DROP TABLE ²"+TestTable$+"²"
  return 
 
sample3:          : ' supprimer des enregistrements avec sélection
  clear 1011
  item_add 1011,"DELETE FROM ²"+TestTable$+"² WHERE "+text$(1031)
  return 
 
sample4:          : ' vider une table de démo
  clear 1011
  item_add 1011,"DELETE FROM ²"+TestTable$+"²"
  return 
 
 
 
start:
  res% = dll_call1("StartSQLite3Transaction",SQL%)
  item_add 1001,"start transaction "+str$(res%)
  return
 
exec:
  res% = dll_call2("ExecuteSQLite3Script",SQL%,handle(1011))
  item_add 1001,"Script execution "+str$(res%)
  clearGrid()
  return
 
commit:
  res% = dll_call1("CommitSQLite3Transaction",SQL%)
  item_add 1001,"commit transaction "+str$(res%)
  return
 
rollback:
  res% = dll_call1("RollbackSQLite3Transaction",SQL%)
  item_add 1001,"irollbacknvalidate transaction "+str$(res%)
  return
 
fill:
  if SQL%=0
    message "No database open"
    return
  end_if
  xNbrRecords% = 10 : ' 500
  min 1020,0 : max 1020,xNbrRecords%
  clear 1011
  for x%=1 to xNbrRecords%
    Position 1020,x% 
    ' construire la requête SQL
    sOtherID$ = str$(int(1 + Rnd(9)))
    sName$ = chr$(int(65+rnd(26)))+str$(x%)
    sNumber$ = rnd(1)
    p% = instr(sNumber$,",")
    if p%>0 then sNumber$ = left$(sNumber$,p%-1)+"."+mid$(sNumber$,p%+1,len(sNumber$))
    sNotes$ = "Possibilité de stocker des données BLOB"
    sSQL$ = "INSERT INTO "+TestTable$+"(Name,OtherID,Number,Notes) VALUES (²"+sName$+"²,"+sOtherID$+","+sNumber$+",²"+sNotes$+"²);"
    item_add 1011,sSQL$
    ' exécuter la requête SQL
    res% = dll_call2("ExecuteSQLite3Script",SQL%,adr(sSQL$))
    if res%<0
      item_add 1011,"Erreur dans requête SQL"
      return
    end_if     
  next x%
  item_add 1011,"Database filled with "+str$(xNbrRecords%)+" records"
  Position 1020,0
  return

fillgrid:
  if SQL%=0
    message "No database open"
    return
  end_if
  ' récupérer le nombre de lignes de la réponse
  RowCount% = dll_call2("GetSQLite3RowCount",SQL%,adr(TestTable$))
  if RowCount%<1
    item_add 1011,"Table "+TestTable$+"manquante ou vide"
    return
  end_if
  grid_row 1034,RowCount%+1
 
  ' charger la table dans le gridRequête SQL
  sSQL$ =        "SELECT * "
  sSQL$ = sSQL$ + "FROM "+testTable$
  sSQL$ = sSQL$ + " WHERE (("+testTable$+".Name)"
  sSQL$ = sSQL$ + " Like ²"+text$(1031)+"²)"
  if text$(1033)<>""
    sSQL$ = sSQL$ + " "+text$(1033)+";"
  else
    sSQL$ = sSQL$ + ";"
  end_if

  ' préparation de la requête: sélection des enregistrements de la table selon les critères
  res% = dll_call2("CompileSQLite3Script",SQL%,adr(sSQL$))

  ' Vider grid
  for i%=2 to RowCount%+1
    for j%=1 to grid_column(1034)
      grid_write 1034,i%,j%,""
    next j%
  next i%
 
  ' boucle d'affichage du résultat
  min 1020,0 : max 1020,5 : position 1020,0
  for i%=1 to RowCount%
    position 1020,i%
    ' Remplissage grid par lecture de chacun des colonnes de chacun des enregistrements
    res% = dll_call1("GetSQLite3NextRow",SQL%)
    if res%<0 then exit_for
    for j%=1 to 5                                     
      res% = dll_call2("GetSQLite3CellText",SQL%,j%)
      grid_write 1034,i%+1,j%,text$(1001)    : ' Ecriture dans la cellule correspondante   
    next j%
  next i%
  res% = dll_call1("FinalizeSQLite3Request",SQL%)   
  return

tables:
  if SQL%=0
    message "No database open"
    return
  end_if
  res% = dll_call1("GetSQLite3TableNames",SQL%)
  item_add 1001,str$(res%)+" tables"
  return
 
columns:
  if SQL%=0
    message "No database open"
    return
  end_if
  s$ = trim$(text$(1031))
  if s$="" then s$ = TestTable$
  res% = dll_call2("GetSQLite3ColumnNames",SQL%,adr(s$))
  item_add 1001,str$(res%)+" colonnes dans table "+s$
  return

clickgrid:
  x% = mouse_x_left_down(1034)
  y% = mouse_y_left_down(1034)
  x% = grid_x_to_column(1034,x%)
  y% = grid_y_to_row(1034,y%) - 1
  s$ = grid_read$(1034,y%+1,x%)
  caption 1036,str$(y%)
  caption 1038,str$(x%)
  text 1040,s$
  id$ = grid_read$(1034,y%+1,1)
  champ$ = grid_read$(1034,1,x%)
  return

maj:
  if x%<2
    message "colonne interdite"
    return
  end_if
  s$ = trim$(text$(1040))
  sSQL$ = "UPDATE TestTable SET "+champ$+" = ²"+s$+"² WHERE ID= ²"+id$+"² ;"
  clear 1011
  item_add 1011,sSQL$
  res% = dll_call2("ExecuteSQLite3Script",SQL%,handle(1011))
  item_add 1001,"UPDATE execution "+str$(res%)
  gosub fillgrid
  item_add 1001,"FILLGRID execution "+str$(res%)
  return

' test_SQLite3.bas

label init, open, close, reset, change, changedir, exit
label sample1, sample2, sample3, sample4
label start, exec, commit, rollback, fill, fillgrid, tables, columns
label clickgrid, maj

dim res%, base$, SQL%, xNbrRecords%, x%, sOtherID$, sName$, sNumber$
dim p%, sNotes$, sSQL$, RowCount%, TestTable$, i%, j%, s$, y%, id$, champ$
  TestTable$ = "TestTable"

full_space 0 : on_close 0,exit

main_menu 1
  sub_menu 11 : parent 11,1 : caption 11,"File"
    sub_menu 111 : parent 111,11 : caption 111,"Initialize SQLite3" : on_click 111,init
    sub_menu 112 : parent 112,11 : caption 112,"Open SQLite3" : on_click 112,open
    sub_menu 113 : parent 113,11 : caption 113,"Close SQLite3" : on_click 113,close
    sub_menu 114 : parent 114,11 : caption 114,"Reset SQLite3" : on_click 114,reset
    sub_menu 115 : parent 115,11 : caption 115,"-"
    sub_menu 116 : parent 116,11 : caption 116,"Change folder" : on_click 116,changedir
    sub_menu 117 : parent 117,11 : caption 117,"Change version" : on_click 117,change
    sub_menu 118 : parent 118,11 : caption 118,"-"
    sub_menu 119 : parent 119,11 : caption 119,"Exit" : on_click 119,exit
  sub_menu 12 : parent 12,1 : caption 12,"Sample scripts SQL"
    sub_menu 121 : parent 121,12 : caption 121,"Create sample table" : on_click 121,sample1
    sub_menu 122 : parent 122,12 : caption 122,"Delete sample table" : on_click 122,sample2
    sub_menu 123 : parent 123,12 : caption 123,"Delete records with selection" : on_click 123,sample3
    sub_menu 124 : parent 124,12 : caption 124,"Empty sample table" : on_click 124,sample4
  sub_menu 13 : parent 13,1 : caption 13,"Execute scripts SQL"
    sub_menu 131 : parent 131,13 : caption 131,"Start transaction" : on_click 131,start
    sub_menu 132 : parent 132,13 : caption 132,"Execute script from memo" : on_click 132,exec
    sub_menu 133 : parent 133,13 : caption 133,"Commit transaction" : on_click 133,commit
    sub_menu 134 : parent 134,13 : caption 134,"Rollback transaction" : on_click 134,rollback
    sub_menu 135 : parent 135,13 : caption 135,"-"
    sub_menu 136 : parent 136,13 : caption 136,"Fill data base" : on_click 136,fill
    sub_menu 137 : parent 137,13 : caption 137,"Fill grid from data base" : on_click 137,fillgrid
    sub_menu 138 : parent 138,13 : caption 138,"Get table names in data base" : on_click 138,tables
    sub_menu 139 : parent 139,13 : caption 139,"Get column names in table 'Critère'" : on_click 139,columns
   

alpha 1000 : top 1000,10 : left 1000,10 : caption 1000,"Réponse de SQLite3:"
memo 1001 : top 1001,30 : left 1001,10 : width 1001,500 : height 1001,300 : bar_both 1001

alpha 1010 : top 1010,350 : left 1010,10 : caption 1010,"Script SQL:"
memo 1011 : top 1011,370 : left 1011,10 : width 1011,500 : height 1011,300 : bar_both 1011

progress_bar 1020 : top 1020,680 : left 1020,10 : width 1020,500

alpha 1030 : top 1030,10 : left 1030,540 : caption 1030,"Critère:"
edit 1031 : top 1031,10 : left 1031,600 : width 1031,300
  text 1031,"A%"
alpha 1032 : top 1032,40 : left 1032,540 : caption 1032,"Paramètre:"
edit 1033 : top 1033,40 : left 1033,600 : width 1033,300
  text 1033,"ORDER BY OtherID ASC"
grid 1034 : top 1034,70 : left 1034,540 : width 1034,500 : height 1034,300
  grid_column 1034,5 : grid_row 1034,500 : grid_column_fixed 1034,0
  grid_one_column_width 1034,1,40
  grid_one_column_width 1034,2,60
  grid_one_column_width 1034,3,80
  grid_one_column_width 1034,4,100
  grid_one_column_width 1034,5,200
  grid_write 1034,1,1,"ID"
  grid_write 1034,1,2,"OtherID"
  grid_write 1034,1,3,"Name"
  grid_write 1034,1,4,"Number"
  grid_write 1034,1,5,"Notes"
  on_click 1034,clickgrid
alpha 1035 : top 1035,390 : left 1035,540 : caption 1035,"Ligne:"
alpha 1036 : top 1036,390 : left 1036,570
alpha 1037 : top 1037,390 : left 1037,600 : caption 1037,"Colonne:"
alpha 1038 : top 1038,390 : left 1038,640
alpha 1039 : top 1039,390 : left 1039,680 : caption 1039,"Valeur:"
edit 1040 : top 1040,390 : left 1040,720 : width 1040,200
button 1041 : top 1041,390 : left 1041,950 : caption 1041,"Mise à jour" : on_click 1041,maj

dll_on "KGF.dll"

end

sub ClearGrid()
dim_local r11%,c1%
  grid_row 1034,1
end_sub

init:
  res% = dll_call0("InitializeSQLite3")
  item_add 1001,"init "+str$(res%)
  res% = dll_call1("GetSQLite3Version",handle(1011))
  item_add 1001,"  version "+str$(res%)
  return

open:
  base$ = "MonTestSQLite2.db"
  SQL% = dll_call2("OpenSQLite3",adr(base$),handle(1001))
  item_add 1001,"open "+str$(SQL%)
 
  ' récupérer le nombre de lignes de la réponse
  RowCount% = dll_call2("GetSQLite3RowCount",SQL%,adr(TestTable$))
  item_add 1001,"  "+str$(rowcount%)+" Lignes dans table "+TestTable$
  return

close:
  SQL% = dll_call1("CloseSQLite3",SQL%)
  item_add 1001,"close "+str$(SQL%)
  return
 
reset:
  res% = dll_call0("ResetSQLite3")
  clear 1001
  item_add 1001,"reset "+str$(res%)
  return
 
change:
  s$ = message_input$("Select SQLite3 version","SQLite3 dll name:","SQLite367")
  res% = dll_call1("SelectAlternativeSQLite3Version",adr(s$))
  if s$="" then s$ = "SQLite367"
  if res%=0 then item_add 1001,"Installation SQLite3: "+s$
  return
   
changedir:
  s$ = message_input$("Select SQLite3 folder","SQLite3 path:","C:\SQLite367")
  res% = dll_call1("SelectAlternativeSQLite3Version",adr(s$))
  if s$="" then s$ = "C:\SQLite367"
  if res%=0 then item_add 1001,"Dossier SQLite3: "+s$
  return
   
exit:
  SQL% = dll_call1("CloseSQLite3",SQL%)
  res% = dll_call0("ResetSQLite3")
  terminate
 
 
 
sample1:          : ' création d'une table de démo
  clear 1011
  item_add 1011,"CREATE TABLE "+TestTable$+" ([ID] INTEGER PRIMARY KEY,[OtherID] INTEGER NULL,"
  item_add 1011,"[Name] VARCHAR (255),[Number] FLOAT, [notes] BLOB);" 
  return 
 
sample2:          : ' supprimer une table de démo
  clear 1011
  item_add 1011,"DROP TABLE ²"+TestTable$+"²"
  return 
 
sample3:          : ' supprimer des enregistrements avec sélection
  clear 1011
  item_add 1011,"DELETE FROM ²"+TestTable$+"² WHERE "+text$(1031)
  return 
 
sample4:          : ' vider une table de démo
  clear 1011
  item_add 1011,"DELETE FROM ²"+TestTable$+"²"
  return 
 
 
 
start:
  res% = dll_call1("StartSQLite3Transaction",SQL%)
  item_add 1001,"start transaction "+str$(res%)
  return
 
exec:
  res% = dll_call2("ExecuteSQLite3Script",SQL%,handle(1011))
  item_add 1001,"Script execution "+str$(res%)
  clearGrid()
  return
 
commit:
  res% = dll_call1("CommitSQLite3Transaction",SQL%)
  item_add 1001,"commit transaction "+str$(res%)
  return
 
rollback:
  res% = dll_call1("RollbackSQLite3Transaction",SQL%)
  item_add 1001,"irollbacknvalidate transaction "+str$(res%)
  return
 
fill:
  if SQL%=0
    message "No database open"
    return
  end_if
  xNbrRecords% = 10 : ' 500
  min 1020,0 : max 1020,xNbrRecords%
  clear 1011
  for x%=1 to xNbrRecords%
    Position 1020,x% 
    ' construire la requête SQL
    sOtherID$ = str$(int(1 + Rnd(9)))
    sName$ = chr$(int(65+rnd(26)))+str$(x%)
    sNumber$ = rnd(1)
    p% = instr(sNumber$,",")
    if p%>0 then sNumber$ = left$(sNumber$,p%-1)+"."+mid$(sNumber$,p%+1,len(sNumber$))
    sNotes$ = "Possibilité de stocker des données BLOB"
    sSQL$ = "INSERT INTO "+TestTable$+"(Name,OtherID,Number,Notes) VALUES (²"+sName$+"²,"+sOtherID$+","+sNumber$+",²"+sNotes$+"²);"
    item_add 1011,sSQL$
    ' exécuter la requête SQL
    res% = dll_call2("ExecuteSQLite3Script",SQL%,adr(sSQL$))
    if res%<0
      item_add 1011,"Erreur dans requête SQL"
      return
    end_if     
  next x%
  item_add 1011,"Database filled with "+str$(xNbrRecords%)+" records"
  Position 1020,0
  return

fillgrid:
  if SQL%=0
    message "No database open"
    return
  end_if
  ' récupérer le nombre de lignes de la réponse
  RowCount% = dll_call2("GetSQLite3RowCount",SQL%,adr(TestTable$))
  if RowCount%<1
    item_add 1011,"Table "+TestTable$+"manquante ou vide"
    return
  end_if
  grid_row 1034,RowCount%+1
 
  ' charger la table dans le gridRequête SQL
  sSQL$ =        "SELECT * "
  sSQL$ = sSQL$ + "FROM "+testTable$
  sSQL$ = sSQL$ + " WHERE (("+testTable$+".Name)"
  sSQL$ = sSQL$ + " Like ²"+text$(1031)+"²)"
  if text$(1033)<>""
    sSQL$ = sSQL$ + " "+text$(1033)+";"
  else
    sSQL$ = sSQL$ + ";"
  end_if

  ' préparation de la requête: sélection des enregistrements de la table selon les critères
  res% = dll_call2("CompileSQLite3Script",SQL%,adr(sSQL$))

  ' Vider grid
  for i%=2 to RowCount%+1
    for j%=1 to grid_column(1034)
      grid_write 1034,i%,j%,""
    next j%
  next i%
 
  ' boucle d'affichage du résultat
  min 1020,0 : max 1020,5 : position 1020,0
  for i%=1 to RowCount%
    position 1020,i%
    ' Remplissage grid par lecture de chacun des colonnes de chacun des enregistrements
    res% = dll_call1("GetSQLite3NextRow",SQL%)
    if res%<0 then exit_for
    for j%=1 to 5                                     
      res% = dll_call2("GetSQLite3CellText",SQL%,j%)
      grid_write 1034,i%+1,j%,text$(1001)    : ' Ecriture dans la cellule correspondante   
    next j%
  next i%
  res% = dll_call1("FinalizeSQLite3Request",SQL%)   
  return

tables:
  if SQL%=0
    message "No database open"
    return
  end_if
  res% = dll_call1("GetSQLite3TableNames",SQL%)
  item_add 1001,str$(res%)+" tables"
  return
 
columns:
  if SQL%=0
    message "No database open"
    return
  end_if
  s$ = trim$(text$(1031))
  if s$="" then s$ = TestTable$
  res% = dll_call2("GetSQLite3ColumnNames",SQL%,adr(s$))
  item_add 1001,str$(res%)+" colonnes dans table "+s$
  return

clickgrid:
  x% = mouse_x_left_down(1034)
  y% = mouse_y_left_down(1034)
  x% = grid_x_to_column(1034,x%)
  y% = grid_y_to_row(1034,y%) - 1
  s$ = grid_read$(1034,y%+1,x%)
  caption 1036,str$(y%)
  caption 1038,str$(x%)
  text 1040,s$
  id$ = grid_read$(1034,y%+1,1)
  champ$ = grid_read$(1034,1,x%)
  return

maj:
  if x%<2
    message "colonne interdite"
    return
  end_if
  s$ = trim$(text$(1040))
  sSQL$ = "UPDATE TestTable SET "+champ$+" = ²"+s$+"² WHERE ID= ²"+id$+"² ;"
  clear 1011
  item_add 1011,sSQL$
  res% = dll_call2("ExecuteSQLite3Script",SQL%,handle(1011))
  item_add 1001,"UPDATE execution "+str$(res%)
  gosub fillgrid
  item_add 1001,"FILLGRID execution "+str$(res%)
  return

        blob% = dll_call2("CreateSQLite3Blob",SQL%,adr(champ$))
        res% = dll_call3("WriteSQLite3Blob",SQL%,blob%,adr(NomFichierBinaire$))
        res% = dll_call3("ReadSQLite3Blob",SQL%,blob%,adr(NomFichierBinaire$))
        res% = dll_call3("UpdateSQLite3Blob",SQL%,blob%,adr(NomFichierBinaire$))
        res% = dll_call2("DeleteSQLite3Blob",SQL%,blob%)
        res% = dll_call2("CloseSQLite3Blob",SQL%,blob%)

' test_ShowMessageModal.bas

label generer

dim res%, titre$, mes$, txt$, b1$, b2$, b3$, code%

caption 0,"Test de la fonction ShowMessageModal
alpha 1 : top 1,10 : left 1,10 : caption 1,"Titre de la fenêtre:"
edit 11 : top 11,10 : left 11,110 : width 11,400
  hint 11,"Le contenu de ce champ sera affiché en tant que titre de la fenêtre de dialogue"

alpha 2 : top 2,40 : left 2,10 : caption 2,"Message:"
edit 21 : top 21,40 : left 21,110 : width 21,400
  hint 21,"Le contenu de ce champ sera affiché dans un libellé de message à l'intérieur de la fenêtre de dialogue"

alpha 3 : top 3,70 : left 3,10 : caption 3,"Label bouton 1:"
edit 31 : top 31,70 : left 31,110 : width 31,400
  hint 31,"Le contenu de ce champ servira de libellé du bouton de gauche."+chr$(13)+chr$(10)+"Si ce champ est vide, ce bouton n'apparaît pas."
  
alpha 4 : top 4,100 : left 4,10 : caption 4,"Label bouton 2:"
edit 41 : top 41,100 : left 41,110 : width 41,400
  hint 41,"Le contenu de ce champ servira de libellé du bouton du milieu."+chr$(13)+chr$(10)+"Si ce champ est vide, ce bouton n'apparaît pas."

alpha 5 : top 5,130 : left 5,10 : caption 5,"Label bouton 3:"
edit 51 : top 51,130 : left 51,110 : width 51,400
  hint 51,"Le contenu de ce champ servira de libellé du bouton de droite."+chr$(13)+chr$(10)+"Si ce champ est vide, ce bouton n'apparaît pas."

alpha 6 : top 6,170 : left 6,10 : caption 6,"Zone texte:"
check 61 : top 61,170 : left 61,110 : width 61,400 : caption 61,"  Saisie d'un texte"  
  hint 61,"Si cette case est cochée, une zone de saisie de texte apparaîtra"
  
button 99 : top 99,230 : left 99,110 : width 99,400 : font_bold 99
  caption 99,"Générer la fenêtre" : on_click 99,generer
  hint 99,"Faire apparaître la fenêtre de dialogue"
  
alpha 7 : top 7,320 : left 7,10 : caption 7,"Code retour:"
edit 71 : top 71,320 : left 71,110 : width 71,30  
alpha 72 : top 72,320 : left 72,150

alpha 8 : top 8,350 : left 8,10 : caption 8,"Texte retourné:"
edit 81 : top 81,350 : left 81,110 : width 81,400  
  
  
dll_on "KGF.dll"
end

generer:
  titre$ = text$(11)
  mes$ = text$(21)
  b1$ = trim$(text$(31))
  b2$ = trim$(text$(41))
  b3$ = trim$(text$(51))
  code% = 0
  if b1$<>"" then code% = code% + 1
  if b2$<>"" then code% = code% + 2
  if b3$<>"" then code% = code% + 4
  if checked(61)=1 then code% = code% + 8
  res% = dll_call6("ShowMessageModal",adr(titre$),adr(mes$), code%, adr(b1$), adr(b2$), adr(b3$))
  text 71,str$(res%)
  select res%
    case 0: caption 72,"Arrêt par la croix rouge"
    case 1: caption 72,"Bouton 1: "+b1$
    case 2: caption 72,"Bouton 2: "+b2$
    case 4: caption 72,"Bouton 3: "+b3$
  end_select
  txt$ = string$(255," ")
  res% = dll_call1("GetShowMessageModalText",adr(txt$))
  text 81,trim$(txt$)
  return

res% = dll_call2("fonctionsSetImportantHandles",handle_application,handle(0))
Cette fonction mémorise deux handles importants pour la fonction SetApplicationIcon

res% = dll_call1("SetApplicationIcon",typ%)
Cette fonction change les icônes de l'application
typ%=0  ==> retour aux icônes initiales
typ%=1  ==> changer l'icône de la barre de titre de la form 0
typ%=2  ==> comme typ%=1, mais change aussu l'icône dans labarre des tâches

' test_SetApplicationIcon.bas

label choixtype, choiximage, appliquer
dim res%, nom$, typ%


' dll_on "KGF.dll"                    : ' uniquement s'il faut utiliser LoadAnyImageFile
dll_on "ApplicationIcons.dll"       : ' suffisant si on n'utilise pas LoadAnyImageFile !

res% = dll_call2("SetImportantHandles",handle_application,handle(0))

open_dialog 1 : filter 1,"Images|*.bmp;*.jpg;*.jpeg"
combo 10 : top 10,10 : left 10,80 : width 10,300 : on_click 10,choixtype
  item_add 10,"Annuler les icônes personnalisées"
  item_add 10,"Icône de la barre de titre"
  item_add 10,"Icône de la barre de titre et de a barre des tâches"
text 10,item_read$(10,1)
typ% = 0

alpha 5 : top 5,40 : left 5,10 : caption 5,"Fichier image: "
edit 6 : top 6,40 : left 6,80 : width 6,300 : inactive 6
button 7 : top 7,40 : left 7,380 : width 7,30 : font_bold 7 : caption 7,"..."
  on_click 7,choiximage
  
button 9 : top 9,70 : left 9,80 : caption 9,"Appliquer" : on_click 9,appliquer
  
picture 2 : top 2,120 : left 2,10 : width 2,32 : height 2,32
  stretch_on 2
  
end

choixtype:
  typ% = item_index(10) - 1
  return

choiximage:
  nom$ = file_name$(1)
  if nom$="_" then return
  text 6,trim$(nom$)
'  res% = dll_call1("LoadAnyImageFile",adr(nom$))     : ' utile si l'on veut utiliser d'autres formats...
  file_load 2,nom$
  clipboard_paste 2
  return

appliquer:
  res% = dll_call1("SetApplicationIcon",typ%)
  message str$(res%)
  return

unit KGF_unit_MDA;

interface

uses
    Windows, SysUtils, Dialogs, Classes, StrUtils, StdCtrls, Messages
    ;


{
  Objet MDA - Multi-DimensionalArray

  Cet objet permet de gérer des tableaux multi-dimensionnels simulés dans un tableau Panoramic uni-dimensionnel.
  L'intérêt de ce système est que les tableaux uni-dimensionnels peuvent facilement être passés en paramètre à la DLL.
  Ce n'est pas le cas des tableaux multi-dimensionnels.
  L'objet MDA est conçu pour donner accès aux fonctions d'une DLL aux données d'un tableau multi-dimensionnel de Panoramic.
  Pour cela, il faut déclarer en Panoramic un tableau uni-dimensionnel selon la formule:
        dim MonTableau((dim1+1) * (dim2+1) * (dim3+1) - 1)
  Exemple:
    dim MonTableau(5,3,7)
  sera remplacé par
    dim MonTableau(6*4*8-1)

  L'implémentation actuelle est prévue pour des tableaux jusqu'à 3 dimensions.

  Un tableau multi-dimensionnel doit être déclaré avec son nom et ses dimenions.
  L'objet MDA mémorise et gère toutes les déclarations ainsi que l'accès physique aux données.
  Deux fonctions exportées (accessibles en Panoramic) permettent définir les tableaux:
      res% = dll_call4("DefineMDA",adt(tableau$),d1%,d2%,d3%)    : ' crée ou modifie la déclaration d'un tableau
      res% = dll_call0("ResetMDA")                                : ' efface toutes les déclarations de tableaux
  Les fonctions et procédures suivantes sont utilisables dans la DLL (en Delphi), mais pas appelables par Panoramic:
      MDA.IndexOfArray(aName: string): string                    retourne l'index du tableau ou -1 si non déclaré
      MDA.TypeOfArray(aName: string): TypMDA                      retourne le type d'un tableau
      MDA.Count: integer;                                        retourne le nombre de tableaux déclarés
      MDA.GetIntegerArrayElement(aIndex, d1,d2,d3: integer; aPanoramic: pinteger): integer    retourne le contenu d'un élément
      MDA.GetFloatArrayElement(aIndex, d1,d2,d3: integer; aPanoramic: pfloat): double          retourne le contenu d'un élément
      MDA.GetStringArrayElement(aIndex, d1,d2,d3: integer; aPanoramic: pinteger): string;      retourne me contenu d'un élément
      MDA.SetIntegerArrayElement(aIndex, d1,d2,d3: integer; aValue: integer; aPanoramic: pinteger)      remplace le contenu d'un élément
      MDA.SetFloatArrayElement(aIndex, d1,d2,d3: integer; aValue: double; aPanoramic: pfloat)          remplace le contenu d'un élément
      MDA.SetStringArrayElement(aIndex, d1,d2,d3: integer; aValue: string; aPanoramic: pinteger)        remplace le contenu d'un élément
}

{
    La constante StringParameterMethod indique la méthode de passage d'une chaîne de caractères en paramètre à une DLL,
    aussi bien en entrée qu'en sortie. Elle détermine comment le résultat de ADR(s$) doit être intreprété:
          Méthode 1:
            ADR(s$) donne l'adresse du premier caractère du texte
          Méthode 2:
            ADR(s$) donne l'adresse d'un mot contenant l'adresse du premier caractère du texte
    Ceci est valable en environnement compilé (PCompiledMode=true).
    En version interprétée (PCompiledMode=false), uniquement la méthode 2 est employée !
}
const StringParameterMethod = 2;
type
  Pfloat = ^Double;

type TypMDA = (tMDAundefined, tMDAfloat, tMDAinteger, tMDAstring);
type TMDA = class
  private
    fNames: array of string;
    fTypes: array of TypMDA;
    fDimensions: array of array of integer;
    fMemoHandle: HWND;
  published
    function IndexOfArray(aName: string): integer;
    function TypeOfArray(aName: string): TypMDA;
    function Count: integer;
    function GetIntegerArrayElement(aIndex, d1,d2,d3: integer; aPanoramic: pinteger): integer;
    function GetFloatArrayElement(aIndex, d1,d2,d3: integer; aPanoramic: pfloat): double;
    function GetStringArrayElement(aIndex, d1,d2,d3: integer; aPanoramic: pinteger): string;
    procedure SetIntegerArrayElement(aIndex, d1,d2,d3: integer; aValue: integer; aPanoramic: pinteger);
    procedure SetFloatArrayElement(aIndex, d1,d2,d3: integer; aValue: double; aPanoramic: pfloat);
    procedure SetStringArrayElement(aIndex, d1,d2,d3: integer; aValue: string; aPanoramic: pinteger);
    procedure AddArray(aName: string; d1, d2, d3: integer);
    procedure ModifyArray(aName: string; d1, d2, d3: integer);
    property MemoHandle: HWND read fMemoHandle write fMemoHandle;
    constructor CreateNew(aMemoHandle: HWND);
    destructor Destroy;
end;

var
  MDA: TMDA;
  PCompiledMode: boolean = false;                      // flag "DLL appelée par un programme compilé"
  // la variable PCompiledMode est initialisée par défaut ) "faux".
  // ce ci signifie que Panoramic est en mode "interprété", pas en mcde "compile"
  // pour développer un code opérationnel dans les deux modes, il faut détecter l'état de l'exécutable.
  // Ceci peut être fait au chzrgement de la DLL, dans la procédure d'initialisation
  // en plaçant cette variable dans une unité de données globales et en appelant ceci:
{
  procedure DetectCompiledMode;
  // routine conçue et testée par Klaus
  var
    exename: string;
    myFile: File;
    data: integer;
  begin
    PCompiledMode := false;                // défaut: généré par Panoramic_Editor.exe ou Panoramic.exe
    exename := application.exename;
    AssignFile(myFile, exename);
    FileMode := fmOpenRead;
    Reset(myFile, 4);  // Now we define one record as 4 byte
    BlockRead(MyFile,data,1);
    CloseFile(MyFile);
    // compilé:    $00905A4D
    // interprété: $00505A4D
    if data<>$00505A4D then PCompiledMode := true;
  end;
}

implementation

// procédure d'aide specifique pour copier un string dans uune variable Panoramic
// procédure compatible avec la version compilée de PANORAMIC
//  s  = string (éventuellement multi-ligne) à envoyer à Panoramic
//  par = identifiant de destination  soit ADR(s$)    soit HANDLE(memo%)
  procedure CopyStringToPanoramic(s: string; par: integer);
  var
    p1, p2: pchar;
    n, p: integer;
    s1, s2: string;
    pi, po: pbyte;
    zero: byte;

  begin
    zero := 0;
    p1 := @zero;
    n := length(s);
    if n>0 then p1 := @s[1];
    if PCompiledMode then begin
      // mode compilé
      pi := pbyte(@s[1]);
{$if StringParameterMethod=1}
      po := pbyte(par);                        // méthode V1 (Jack): ADR(s$) pointe vers l'adresse du premier caractère
{$else}
      po := pbyte(pinteger(par)^);              // méthode V2 (Jack): ADR(s$) pointe vers un mot contenant l'adresse du premier caractère
{$ifend}
      while po^<>0 do begin
        if pi^<>0 then begin
          po^ := pi^;
          inc(po);
          inc(pi);
        end else begin
          po^ := 32;
          inc(po);
        end;
      end;
    end else begin
      //mode interprété
      if n>0 then p1 := pchar(@s[1]);
      p2 := pchar(pinteger(par)^);
      while p2^<>#0 do begin
        if n>0 then begin
                if p1<>#0 then p2^ := p1^
                          else dec(p2);
              end else begin
                p2^ := #32;
              end;
        inc(p1);
        inc(p2);
        dec(n);
      end;
    end;
  end;


constructor TMDA.CreateNew(aMemoHandle: HWND);
begin
  inherited;
  SetLength(fNames,0);
  SetLength(fTypes,0);
  SetLength(fDimensions,0);
  MemoHandle := aMemoHandle;
end;

destructor TMDA.Destroy;
begin
  SetLength(fNames,0);
  SetLength(fTypes,0);
  SetLength(fDimensions,0);
  inherited;
end;

function TMDA.IndexOfArray(aName: string): integer;
var
  i: integer;
begin
  result := -1;
  if Length(fNames)=0 then exit;
  for i:=0 to high(fNames) do begin
    if fNames[i]=aName then begin
      result := i;
      exit;
    end;
  end;
end;

function TMDA.TypeOfArray(aName: string): TypMDA;
var
  i: integer;
begin
  result := tMDAundefined;
  i := IndexOfArray(aName);
  if i>=0 then result := fTypes[i];
end;

function TMDA.Count: integer;
begin
  result := Length(fNames);
end;

function TMDA.GetIntegerArrayElement(aIndex, d1,d2,d3: integer; aPanoramic: pinteger): integer;
var
  pi: pinteger;
  offset: integer;
begin
  result := 0;
  if (aIndex<0) or (aIndex>high(fNames)) then exit;
  if fTypes[aIndex]<>tMDAinteger then exit;
  pi := aPanoramic;
  offset := 0;
  if fDimensions[aIndex][1]>0 then begin
    offset := offset + d1*fDimensions[aIndex][1];
    if fDimensions[aIndex][2]>0 then begin
      offset := offset + d2*fDimensions[aIndex][2];
      offset := offset + d3;
    end else begin
      offset := offset + d2;
    end;
  end else begin
    offset := d1;
  end;
  inc(pi,offset);
  result := pi^;
end;

function TMDA.GetFloatArrayElement(aIndex, d1,d2,d3: integer; aPanoramic: pfloat): double;
var
  pf: pfloat;
  offset: integer;
begin
  result := 0;
  if (aIndex<0) or (aIndex>high(fNames)) then exit;
  if fTypes[aIndex]<>tMDAfloat then exit;
  pf := aPanoramic;
  offset := 0;
  if fDimensions[aIndex][1]>0 then begin
    offset := offset + d1*fDimensions[aIndex][1];
    if fDimensions[aIndex][2]>0 then begin
      offset := offset + d2*fDimensions[aIndex][2];
      offset := offset + d3;
    end else begin
      offset := offset + d2;
    end;
  end else begin
    offset := d1;
  end;
  inc(pf,offset);
  result := pf^;
end;

function TMDA.GetStringArrayElement(aIndex, d1,d2,d3: integer; aPanoramic: pinteger): string;
var
  pi: pinteger;
  offset: integer;
  adr: integer;
  s: string;
begin
  result := '';
  if (aIndex<0) or (aIndex>high(fNames)) then exit;
  if fTypes[aIndex]<>tMDAstring then exit;
  pi := aPanoramic;
  offset := 0;
  if fDimensions[aIndex][1]>0 then begin
    offset := offset + d1*fDimensions[aIndex][1];
    if fDimensions[aIndex][2]>0 then begin
      offset := offset + d2*fDimensions[aIndex][2];
      offset := offset + d3;
    end else begin
      offset := offset + d2;
    end;
  end else begin
    offset := d1;
  end;

//  if MemoHandle<>0 then DumpPanoramic(MemoHandle,integer(pi),48);
//showmessage('a4');

  inc(pi,offset);
  result := pstring(pi)^;
end;


procedure TMDA.SetIntegerArrayElement(aIndex, d1,d2,d3: integer; aValue: integer; aPanoramic: pinteger);
var
  pi: pinteger;
  offset: integer;
begin
  if (aIndex<0) or (aIndex>high(fNames)) then exit;
  pi := aPanoramic;
  offset := 0;
  if fDimensions[aIndex][1]>0 then begin
    offset := offset + d1*fDimensions[aIndex][1];
    if fDimensions[aIndex][2]>0 then begin
      offset := offset + d2*fDimensions[aIndex][2];
      offset := offset + d3;
    end else begin
      offset := offset + d2;
    end;
  end else begin
    offset := d1;
  end;
  inc(pi,offset);
  pi^ := aValue;
end;

procedure TMDA.SetFloatArrayElement(aIndex, d1,d2,d3: integer; aValue: double; aPanoramic: pfloat);
var
  pf: pfloat;
  offset: integer;
begin
  if (aIndex<0) or (aIndex>high(fNames)) then exit;
  pf := aPanoramic;
  offset := 0;
  if fDimensions[aIndex][1]>0 then begin
    offset := offset + d1*fDimensions[aIndex][1];
    if fDimensions[aIndex][2]>0 then begin
      offset := offset + d2*fDimensions[aIndex][2];
      offset := offset + d3;
    end else begin
      offset := offset + d2;
    end;
  end else begin
    offset := d1;
  end;
  inc(pf,offset);
  pf^ := aValue;
end;

procedure TMDA.SetStringArrayElement(aIndex, d1,d2,d3: integer; aValue: string; aPanoramic: pinteger);
var
  pi: pinteger;
  offset: integer;
begin
  if (aIndex<0) or (aIndex>high(fNames)) then exit;
  pi := aPanoramic;
  offset := 0;
  if fDimensions[aIndex][1]>0 then begin
    offset := offset + d1*fDimensions[aIndex][1];
    if fDimensions[aIndex][2]>0 then begin
      offset := offset + d2*fDimensions[aIndex][2];
      offset := offset + d3;
    end else begin
      offset := offset + d2;
    end;
  end else begin
    offset := d1;
  end;
  inc(pi,offset);
  CopyStringToPanoramic(aValue,integer(pi));
end;


procedure TMDA.AddArray(aName: string; d1, d2, d3: integer);
var
  i: integer;
begin
  i := Length(fNames);
  SetLength(fNames,i+1);
  SetLength(fTypes,i+1);
  SetLength(fDimensions,i+1);
  SetLength(fDimensions[i],3);
  fNames[i] := aName;
  fTypes[i] := tMDAfloat;
  if RightStr(aName,1)='%' then fTypes[i] := tMDAinteger;
  if RightStr(aName,1)='$' then fTypes[i] := tMDAstring;
  fDimensions[i][0] := d1;
  fDimensions[i][1] := d2;
  fDimensions[i][2] := d3;
end;

procedure TMDA.ModifyArray(aName: string; d1, d2, d3: integer);
var
  i: integer;
begin
  i := self.IndexOfArray(aName);
  fNames[i] := aName;
  fTypes[i] := tMDAfloat;
  if RightStr(aName,1)='%' then fTypes[i] := tMDAinteger;
  if RightStr(aName,1)='$' then fTypes[i] := tMDAstring;
  fDimensions[i][0] := d1;
  fDimensions[i][1] := d2;
  fDimensions[i][2] := d3;
end;




// copier un tableau de type integer de Panoramic dans un tableau dynamique Delphi dans la DLL
function GetIntegerArrayFromPanoramic(aIntegerArray: pinteger; nDimension: integer): integer; stdcall; export;
var
  IntegerArray: array of Integer;
  i: integer;
  pi: pinteger;
begin
  result := -1;
  try
    if aIntegerArray=nil then exit;            // il faut au moins une adresse
    if nDimension<0 then exit;                // il faut une dimenion Panoramic valide
    SetLength(IntegerArray,nDimension+1);      // affecter la mémoire
    pi := aIntegerArray;                      // boucle de lecture
    for i:=0 to nDimension do begin
      IntegerArray[i] := pi^;                  // ccpier un élément
      inc(pi);                                // ajuster le pointeur
showmessage(format('GetIntegerArrayFromPanoramic  %d: %d',[i,IntegerArray[i]]));  // juste pour montrer le résultat - ligne à supprimer !
    end;
    result := 0;
  except
  end;
end;
exports GetIntegerArrayFromPanoramic;

// copier un tableau de type integer d'un tableau dynamique Delphi dans la DLL vers un tableau dans Panoramic
function SetIntegerArrayFromPanoramic(aIntegerArray: pinteger; nDimension: integer): integer; stdcall; export;
var
  IntegerArray: array of Integer;
  i: integer;
  pi: pinteger;
begin
  result := -1;
  try
    if aIntegerArray=nil then exit;                  // il faut au moins une adresse
    if nDimension<0 then exit;                      // il faut une dimenion Panoramic valide

    // les 2 lignes suivantes sont là pour "simuler" un tableau existant dans la DLL...
    SetLength(IntegerArray,nDimension+1);            // affecter la mémoire
    for i:=0 to nDimension do IntegerArray[i] := i*2;

    if nDimension>=Length(IntegerArray) then exit;  // trop de données demandées ?
    pi := aIntegerArray;                            // boucle d'écriture
    for i:=0 to nDimension do begin
      pi^ := IntegerArray[i];                          // ccpier un élément
      inc(pi);                                        // ajuster le pointeur
    end;
    result := 0;
  except
  end;
end;
exports SetIntegerArrayFromPanoramic;

// copier un tableau de type float de Panoramic dans un tableau dynamique Delphi dans la DLL
function GetFloatArrayFromPanoramic(aFloatArray: pfloat; nDimension: integer): integer; stdcall; export;
var
  FloatArray: array of double;
  i: integer;
  pf: pfloat;
begin
  result := -1;
  try
    if aFloatArray=nil then exit;              // il faut au moins une adresse
    if nDimension<0 then exit;                // il faut une dimenion Panoramic valide
    SetLength(FloatArray,nDimension+1);        // affecter la mémoire
    pf := aFloatArray;                        // boucle de lecture
    for i:=0 to nDimension do begin
      FloatArray[i] := pf^;                      // ccpier un élément
      inc(pf);                                  // ajuster le pointeur
showmessage(format('GetFloatArrayFromPanoramic  %d: %f',[i,FloatArray[i]]));  // juste pour montrer le résultat - ligne à supprimer !
    end;
    result := 0;
  except
  end;
end;
exports GetFloatArrayFromPanoramic;

// copier un tableau de type float d'un tableau dynamique Delphi dans la DLL vers un tableau dans Panoramic
function SetFloatArrayFromPanoramic(aFloatArray: pfloat; nDimension: integer): integer; stdcall; export;
var
  FloatArray: array of double;
  i: integer;
  pf: pfloat;
begin
  result := -1;
  try
    if aFloatArray=nil then exit;                    // il faut au moins une adresse
    if nDimension<0 then exit;                      // il faut une dimenion Panoramic valide

    // les 2 lignes suivantes sont là pour "simuler" un tableau existant dans la DLL...
    SetLength(FloatArray,nDimension+1);              // affecter la mémoire
    for i:=0 to nDimension do FloatArray[i] := i*2.002;

    if nDimension>=Length(FloatArray) then exit;    // trop de données demandées ?
    pf := aFloatArray;                              // boucle de lecture
    for i:=0 to nDimension do begin
      pf^ := FloatArray[i];                            // ccpier un élément
      inc(pf);                                        // ajuster le pointeur
    end;
    result := 0;
  except
  end;
end;
exports SetFloatArrayFromPanoramic;

{
  Objet MDA - Multi-DimensionalArray

  Cet objet permet de gérer des tableaux multi-dimensionnels simulés dans un tableau Panoramic uni-dimensionnel.
  L'intérêt de ce système est que les tableaux uni-dimensionnels peuvent facilement être passés en paramètre à la DLL.
  Ce n'est pas le cas des tableaux uni-dimensionnels.

  L'implémentation actuelle est prévue pour des tableaux jusqu'à 3 dimensions.

}

function GetStringFromPanoramic(par: integer): string;
begin
  result := pstring(par)^;
end;

// cette fonction ajoute ou modifie la déclaration d'un tableau
function DefineMBA(aName: integer; d1, d2, d3: integer; hMemo: HWND): integer; stdcall; export;
var
  s: string;
  index: integer;
begin
  result := -1;
  try
    if not assigned(MDA) then MDA := TMDA.CreateNew(hMemo);                    // créer la table maître si besoin
    s := Trim(GetStringFromPanoramic(aName));                                  // prendre le nom Panoramic du tableau
    if s='' then exit;                                                          // nom manquant ?
    index := MDA.IndexOfArray(s);                                              // chercher le tableau dans la table maître
    if index<0 then begin                                                      // tableau pas encore enregistré ?
      MDA.AddArray(s,d1,d2,d2);                                                //  ajouter une nouvelle déclaration
    end else begin                                                              // tableau déjà enregistré - changer dimensions
      MDA.ModifyArray(s,d1,d2,d3);                                              //  modifier la définition du tableau
    end;
    result := MDA.IndexOfArray(s);                                              // retourner l'indice du tableau
  except
  end;
end;
exports DefineMBA;

// cette fonctiob efface toutes les déclarations de tableaux (PAS LES TABLEAUX !)
function ResetMDA: integer; stdcall; export;
begin
  result := -1;
  try
    if not assigned(MDA) then exit;
    MDA.Free;
    result := 0;
  except
  end;
end;
exports ResetMDA;



function TestStringArray(ind: integer; aArray: pinteger; d1,d2,d3: integer): integer; stdcall; export;
var
  s, s1: string;
begin
  result := -1;
  try
    if not assigned(MDA) then exit;
    if (ind<0) or (ind>=MDA.Count) then exit;
    s := MDA.GetStringArrayElement(ind,d1,d2,d3,aArray);
    if MDA.MemoHandle<>0 then begin
      s := format('%d,%d = %s',[d1,d2,s]);
      SendMessage(MDA.MemoHandle,WM_SETTEXT,0,integer(@s[1]));
    end;
    s1 := 'ABCDEFG';
    MDA.SetStringArrayElement(ind,d1,d2,d3,s1,aArray);
    result := 0;
  except
  end;
end;
exports TestStringArray;


end.

' dim strings$(5,3)
dim strings$(6*4-1)     : ' les longueurs des dimensions sont 6 x 4 cases !

' Tableau_string_en_2_dimensions_avec_Panoramic_et_DLL.bas

dim res%, i%, j%, s$, nom$, ind%, m1%
m1% = -1

' dim strings$(5,3)
dim strings$(6*4-1)     : ' les longueurs des dimensions sont 6 x 4 cases !

full_space 0
memo 1 : top 1,0 : left 1,250 : width 1,300 : height 1,500 : bar_both 1

for i%=0 to 5
  for j%=0 to 3
    s$ = str$(i%)+","+str$(j%)
' message str$(i%)+","+str$(j%)+"="+s$    
    strings$(s$,i%,j%)
  next j%
next i%

for i%=0 to 5
  s$ = ""
  for j%=0 to 3
    s$ = s$ + fstrings$(i%,j%) + "   "
  next j%
  print s$
next i%

dll_on "KGF.dll"
nom$ = "entiers$"
ind% = dll_call5("DefineMBA",adr(nom$),5,3,0,handle(1))
message "DefineMBA: index  = "+str$(ind%)
res% = adr(strings$)
res% = dll_call5("TestStringArray",ind%,adr(strings$),3,2,m1%)  : ' lire l'élément (3,2) et le remplacer par "ABCDEF"
message "TestStringArray = "+str$(res%)

print
print "strings$(3,2) remplacé par ABCDEF:"
for i%=0 to 5
  s$ = ""
  for j%=0 to 3
    s$ = s$ + fstrings$(i%,j%) + "   "
  next j%
  print s$
next i%

end

' *** lire l'élément (i%,j%) du tableau entiers%
' ATTENTION: la fonction ne peut PAS avoir le même nom que le tableau !
'            Son nom est donc précédé d'un "f" pour signaler "fonction"
fnc fstrings$(i%,j%)
  result strings$(i%*4+j%)     : ' la première dimension a une longueur de 6 !
end_fnc

' *** écrire la valeur v$ dans l'élémént (i%,j%) du tableau strings$
sub strings$(v$,i%,j%)
  strings$(i%*4+j%) = v$
end_sub

dim RE1%, res%, f$
DLL_ON "C:\PANORAMIC\KGF\KGF.dll"
   RE1% = dll_call1("RichEditCreate",handle(0))
   f$ = "Z:\Test.txt"
   res% = dll_call2("RichEditFileInsert",RE1%,adr(f$))
DLL_OFF
END

res% = dll_call2("SaveScannerImageToFile",TW%,fadr(fichier$))

EVENT:
  if bin_and(user_event_wparam,hex$("FF000000"))=hex$("05000000")
      if bin_and(user_event_wparam,hex$("00FF0000"))=hex$("010000")
        Active 0       
      end_if
  end_if
return