Panoramic Data Créateur

Application_Title "Panoramic Data Création"
 Constantes()
 Variables()
 Events()
 Interface()
 Init()
End
' Déclaration des constantes____________________________________________________
Sub Constantes()
  Dim Dos$ : Dos$=Dir_Current$
Dim KGF$ :KGF$=Dos$+"\KGF.dll"
End_Sub
' Déclaration des variables globales____________________________________________
Sub Variables()
  Dim Clic% , Change% ,Mode%, F_Out$
End_Sub
' Déclaration des évènements____________________________________________________
Sub Events()
  Label Clic,Change,Close_100
End_Sub
' Mise en place de l'interface utilisateur______________________________________
Sub Interface()
  O_Form(0,0,1,0,0,465,595,"Panoramic Data Création"):font_name 0,"arial"
  O_Main_Menu(1,0)
  O_Sub_Menu(2,1,"Fichier",0,1)
  O_Sub_Menu(3,2,"Ouvrir",1,1):O_Sub_Menu(4,2,"Enregistrer",1,0):O_Sub_Menu(5,2,"Quitter",1,1)
  O_Sub_Menu(6,1,"Convertir",1,0)
  O_Sub_Menu(7,1,"A Propos...",1,1)
  O_Sub_Menu(8,1,"?",1,1)
  O_Picture(9,0,0,5,5,378,567,""):color 9,0,0,0
  O_Memo(10,0,0,5,5,378,567):Bar_Both 10
  O_Statut_Bar2(11,0,1,1)
  O_progress_Bar(12,0,0,387,420,0,100)
  O_Alpha(13,0,0,387,10,0,0,""):color 13,250,235,235:font_color 13,0,0,255
  O_Alpha(15,0,0,389,525,0,0,""):color 15,250,235,235:font_color 15,0,0,255
End_Sub
' Initialisations de base_______________________________________________________
Sub Init()
  Dim_local Aide$
  Aide$=dir_current$+"\Aide.pdc"
  O_DList(14,Aide$)
End_Sub
' Menu des évènements clics_____________________________________________________
Clic:
  Clic%=Number_Click
  Select Clic%
  Case 3 :Ouvrir():Active 6
  Case 4 :Enregistrer()
  Case 5 :Quitter()
  Case 6 :Convertir():active 4
  Case 7 :APp()
  Case 8 :Aide()
  Case 204: execute a$
  Case 301: Affich_Aide()
  End_Select
Return
' Menu des évènements change____________________________________________________
Change:
  Change%=Number_Change
  Select Change%
  End_Select
Return
' Evènement on_close____________________________________________________________
Close_100:
  top 0,(screen_y-465)/2
  HIDE 12 :POSITION 12,0 :hide 15
  Caption 13,file_extract_name$(File$)
  inactive 4
return
' Menu Ouvrir
Sub Ouvrir()
  if object_exists(100)=1:if show(100)=1:hide 100:End_If:End_If
  if show(12)=1 then hide 12
  if show(15)=1 then hide 15
  Position 12,0 :caption 13,""
  O_Open_Dialog(0,"*.txt,*.bas,*.jpg,*.bmp|*.txt;*.bas;*.jpg;*.bmp",5)
  if File$ <> ""
      if right$(File$,3)="txt" or right$(File$,3)="bas"
        Hide 9 : Show 10 :clear 10 :Mode%=1
        File_Load 10,File$
'        ici j'en profite pour définir le nom de sortie du fichier
'        je rajoute "_txt.bas" pour memo le fichier contient du texte
        F_Out$=file_extract_name$(File$)
        F_Out$=Left$(F_Out$,len(F_Out$)-4)+"_txt.bas"
      Else
        Hide 10 : Show 9 :Mode%=2
        Get_Size(File$)
        Appercu(File$,L%,H%,9)
'        ici j'en profite pour définir le nom de sortie du fichier
'        je rajoute "_img.bas" pour memo le fichier contient une image
        F_Out$=file_extract_name$(File$)
        F_Out$=Left$(F_Out$,len(F_Out$)-4)+"_img.bas"
      End_If
      show 13 :Caption 13,file_extract_name$(File$)
  End_If
End_Sub

Sub Get_Size(a$)
  Dim_Local res%
  if variable("L%")=0 then Dim L%
  if variable("H%")=0 then Dim H%
  if variable("f$")=0 then Dim f$
  f$=a$
  dll_on KGF$
  res%=dll_call3("AnalyzeImageFile",adr(f$),adr(L%),adr(H%))
  if res%=1
      message "Extension de fichier invalide !"
  end_if
  dll_off
End_Sub

Sub Appercu(I$,L%,H%,No%)
  Dim_Local x%,y%,z
  x%=L% :y%=H% :z=1
  if x%>y%
      while x%>567 or y%>378
        z=z-0.01
        x%=x%*z
        y%=y%*z
      end_while
  else
      while y%>378 or x%>567
        z=z-0.01
        x%=x%*z
        y%=y%*z
      end_while
  end_if
  width No%,x% : height No%,y%
  File_load No%,I$ : Stretch_On No%
End_Sub
' Menu Enregistrer______________________________________________________________
Sub Enregistrer()
  dim_local a$,b$
  Save_dialog 500
  filter 500,"*.bas|*.bas"
  a$=file_name$(500)
  if mode%=1
      b$="_txt.bas"
  else
      b$="_bmp.bas"
  end_if
  if right$(a$,8)<>b$:a$=a$+b$:end_if
  file_save 101,a$
  hide 100 :hide 12 :hide 15
  inactive 4
  caption 13,file_extract_name$(File$)
End_Sub
' Menu Quitter__________________________________________________________________
Sub Quitter()
  Terminate
End_Sub
' Menu Convertir________________________________________________________________
Sub Convertir()
  Dim_local x%
  If hide(12)=1 : Show 12 :End_If
  if Mode%=1 : x%=count(10) :End_If
  if Mode%=2 : x%=L%*H%    :End_If
  top 0,((screen_y-465)/2)-100
  If Object_Exists(100)=0
      O_Form(100,0,1,top(0)+height(0),left(0),200,595,"Data Preview"):font_name 100,"arial"
      O_Memo(101,100,1,0,0,140,578):Bar_Both 101:font_size 101,8
      O_Statut_Bar2(102,100,1,0)
      O_Alpha(103,100,1,height(100)-58,10,0,0,""):font_color 103,0,0,255
  Else
      Clear 101:Show 100
  End_If
  Show 13 :caption 13,"Convertion en cours..."
  show 15
  caption 103,file_extract_name$(File$)
  Min 12,0:Max 12,x%
  position 12,0
  On_close 100,Close_100
  If Mode%=1 then Ecriture_Text()
  If Mode%=2 then Ecriture_Image()
End_Sub

Sub Ecriture_Text()
  Dim_Local x%,a$,nom$
  nom$=file_extract_name$(File$)
  item_add 101,"data"+chr$(32)+chr$(34)+left$(nom$,len(nom$)-4)+"_"+right$(nom$,3)+chr$(34)
  for x%=1 to count(10)
      a$=item_read$(10,x%)
      a$="Data"+chr$(32)+chr$(34)+a$+chr$(34)
      item_add 101,a$
      position 12,x%
      calc_pourcent(x%,count(10))
  next x%
  caption 13,"Convertion terminée !"
End_Sub

Sub Ecriture_Image()
  Dim_Local nom$,x%,y%,R1%,G1%,B1%,cpt%,line$
  nom$=file_extract_name$(File$)
  nom$=LEFT$(nom$,len(nom$)-4)+"_bmp"
  item_add 101,"Sub Read_"+nom$+"(No%)"
  item_add 101,"  Dim_local x%,y%,nom$,R%,G%,B%"
  item_add 101,"  Restore"
  item_add 101,"  read nom$"
  item_add 101,"  while nom$<>"+chr$(34)+nom$+chr$(34)
  item_add 101,"  read nom$"
  item_add 101,"  End_while"
  item_add 101,"  2D_Target_Is No%"
  item_add 101,"  For y%=0 To "+str$(L%-1)
  item_add 101,"      For x%=0 To "+str$(H%-1)
  item_add 101,"        Read R% :Read G%  :Read B%"
  item_add 101,"        2D_Pen_Color R%,G%,B%"
  item_add 101,"        2D_Point y%,x%"
  item_add 101,"      Next x%"
  item_add 101,"  Next y%"
  item_add 101,"End_Sub"
  item_add 101,""
  item_add 101,"Data "+chr$(34)+nom$+chr$(34)
      for x%=0 to L% -1
        line$=""
        for y%= 0 to H% -1
            cpt%=cpt%+1
            R1% =color_pixel_red(9,x%,y%)
            G1% =color_pixel_green(9,x%,y%)
            B1% =color_pixel_blue(9,x%,y%)
            if y%<H%-1
              line$=line$+str$(R1%)+","+str$(G1%)+","+str$(B1%)+","
            else
              if y%=H%-1
                  line$=line$+str$(R1%)+","+str$(G1%)+","+str$(B1%)
              end_if
            end_if
            position 12,cpt%
            calc_pourcent(cpt%,L%*H%)
            Display
        next y%
        item_add 101,"data "+line$
      next x%
      caption 13,"Convertion terminée !"
End_Sub

Sub calc_pourcent(P%,NMax%)
    dim_local x%
    x%=int((100*P%)/NMax%)
    caption 15,str$(x%)+" %"
end_sub
' Menu A Propos_________________________________________________________________
Sub APp()
  Dim_local a$
  If Object_Exists(200)=0
      O_Form(200,0,1,0,0,200,400,"A Propos..."):font_name 200,"Arial"
      O_Alpha(201,200,1,10,160,0,0,"Créé avec :")
      O_Alpha(202,200,1,30,140,0,0,"Panoramic")
      font_bold 202 :font_size 202,16:font_color 202,0,0,255
      O_Alpha(203,200,1,55,155,0,0,"Vs 0.9.24.i10")
      font_italic 203:font_color 203,90,90,90
      a$="http://panoramic-language.pagesperso-orange.fr/index.html"
      O_Alpha(204,200,1,80,50,0,0,a$)
      font_color 204,100,0,255 :cursor_point 204:On_Click 204,Clic
      O_Alpha(205,200,1,100,180,0,0,"Par :")
      O_Alpha(206,200,1,120,150,0,0,"y.geronimi")
      font_size 206,12:font_color 206,0,0,255
  Else
      Show 200
  End_If
End_Sub
' Menu AIde_____________________________________________________________________
Sub Aide()
  If Object_Exists(300)=0
      O_Form(300,0,1,0,0,250,450,"Aide"):font_name 300,"arial"
      O_List(301,300,1,0,0,212,150,""):font_color 301,114,0,20:cursor_point 301:On_Click 301,Clic
      O_Memo(302,300,1,0,150,212,284):font_color 302,0,0,255
      item_add 301,"-Ouvrir":item_add 301,"-Enregistrer":item_add 301,"-Quitter":item_add 301,"-Convertir"
  Else
      Show 300
  End_If
End_Sub

Sub Affich_Aide()
  Dim_local a$,b$,x%,y%,z%,debut%,fin%
  clear 302
  debut%=0 : fin%=0 : a$="" :b$=""
  a$=item_index$(301)
  if count(14)>0
  for x%=1 to count(14)
      b$=trim$(item_read$(14,x%))
      b$=right$(b$,len(b$)-1)
      if b$=a$
        debut% = x%+1
        exit_for
      end_if
  next x%
  for z%=debut% to count(14)
      if left$(item_read$(14,z%),1)="#"
        fin%=z%-1
        exit_for
      else
        fin%=count(14)
      end_if
  next z%
  if debut%<fin% or debut%=fin%
      for y%=debut% to fin%
        item_add 302,item_read$(14,y%)
      next y%
  end_if
  end_if
End_Sub
' Includes______________________________________________________________________
#include "Objet_Lib.bas"

Variables()
Labels()
Gui()

end

' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

SUB Variables()
  dim_local i%

'  adresses des fichiers externes
  dim kgf$      : kgf$ = "C:\PROGRA~2\PANORA~1\PPE_Vs4b\dll\KGF.dll"
  dim file$
 
'  évenements
  dim clic%

'  objets
  dim no%
  dim mem%      : no%=no%+1 : mem%  = no%
  dim MM%      : no%=no%+1 : MM%  = no%
  dim SM%(10)  : for i% = 1 to 10 : no%=no%+1 : SM%(i%)= no% : next i%
  dim Pan%      : no%=no%+1 : Pan%  = no%
  dim Pict%    : no%=no%+1 : Pict% = no%

'  boites de dialogue
  dim OpenDial% : no%=no%+1 : OpenDial% = no%
  dim SaveDial% : no%=no%+1 : SaveDial% = no%
 
'  fonctions
  dim L%
  dim H%
 
END_SUB

' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

SUB Labels()
  label clic
END_SUB

' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

SUB Gui()
  Caption 0,"Image >> Data"
  height 0,500 : width 0,700
  top 0,(screen_y-height(0))/2 : left 0,(screen_x-width(0))/2

  Dlist mem%
  Main_menu MM%
  Sub_menu SM%(1) : Parent SM%(1),MM% : Caption SM%(1),"Ouvrir"      : On_click SM%(1),Clic
  Sub_menu SM%(2) : Parent SM%(2),MM% : Caption SM%(2),"Convertir"  : On_click SM%(2),Clic : Inactive SM%(2)
  Sub_menu SM%(3) : Parent SM%(3),MM% : Caption SM%(3),"Enregistrer" : On_click SM%(3),Clic : Inactive SM%(3)
  Panel Pan%      : Full_space Pan%
  Picture Pict%  : Parent Pict%,Pan% : Hide Pict%
END_SUB

' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

Clic:
  clic% = number_click
  if clic% = SM%(1) :OpenFile()      : end_if
  if clic% = SM%(2) :Ecriture_Image() : end_if
  if clic% = SM%(3) :Enregistrer()    : end_if
return

' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

SUB OpenFile()
  dim_local i%
  Inactive SM%(3)
  Open_Dialog OpenDial%
  Dir_dialog OpenDial%,"\"
  Filter OpenDial%,"*.bmp;*.jpg|*.bmp;*.jpg"
  file$=File_name$(OpenDial%)
  Delete OpenDial%
  if file$="_"
      i%=message_information_ok("Vous devez sélectionner un fichier !")
      exit_sub
  end_if
  Caption 0,"Image >> Data  [ "+file_extract_name$(file$)+" ]"
  DetectSize()
  View(L%,H%)
  Active SM%(2)
END_SUB

' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

Sub DetectSize()
  Dim_Local res%
  dll_on KGF$
  res%=dll_call3("AnalyzeImageFile",adr(file$),adr(L%),adr(H%))
  if res%=1
      message "Extension de fichier invalide !"
  end_if
  dll_off
End_Sub

' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

SUB View(L%,H%)
  Dim_Local x%,y%,z
  x%=L% :y%=H% :z=1
  if x%>y%
      while x%>width(pan%) or y%>Height(pan%)
        z=z-0.01
        x%=x%*z
        y%=y%*z
      end_while
  else
      while y%>height(pan%) or x%>width(pan%)
        z=z-0.01
        x%=x%*z
        y%=y%*z
      end_while
  end_if
  width Pict%,x% : height Pict%,y%
  File_load Pict%,file$ : Stretch_On Pict%
  show Pict%
END_SUB

' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

SUB Ecriture_Image()
  Dim_Local nom$,x%,y%,R1%,G1%,B1%,cpt%,line$
  Clear mem%
  Inactive SM%(1)
  Inactive SM%(3)
  nom$=file_extract_name$(File$)
  nom$=LEFT$(nom$,len(nom$)-4)+"_bmp"
  item_add mem%,"Sub Read_"+nom$+"(No%)"
  item_add mem%,"  Dim_local x%,y%,nom$,R%,G%,B%"
  item_add mem%,"  Restore"
  item_add mem%,"  read nom$"
  item_add mem%,"  while nom$<>"+chr$(34)+nom$+chr$(34)
  item_add mem%,"  read nom$"
  item_add mem%,"  End_while"
  item_add mem%,"  2D_Target_Is No%"
  item_add mem%,"  For y%=0 To "+str$(L%-1)
  item_add mem%,"      For x%=0 To "+str$(H%-1)
  item_add mem%,"        Read R% :Read G%  :Read B%"
  item_add mem%,"        2D_Pen_Color R%,G%,B%"
  item_add mem%,"        2D_Point y%,x%"
  item_add mem%,"      Next x%"
  item_add mem%,"  Next y%"
  item_add mem%,"End_Sub"
  item_add mem%,""
  item_add mem%,"Data "+chr$(34)+nom$+chr$(34)
      for x%=0 to L% -1
        line$=""
        for y%= 0 to H% -1
            cpt%=cpt%+1
            R1% =color_pixel_red(Pict%,x%,y%)
            G1% =color_pixel_green(Pict%,x%,y%)
            B1% =color_pixel_blue(Pict%,x%,y%)
            line$=str$(R1%)+","+str$(G1%)+","+str$(B1%)
            item_add mem%,"data "+line$
            calc_pourcent(cpt%,L%*H%)
            Display
        next y%
      next x%
  caption 0,"Image >> Data  [ "+file_extract_name$(file$)+" ] Convertion terminée !"
  active SM%(1)
  active SM%(3)
END_SUB

' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

Sub calc_pourcent(P%,NMax%)
    dim_local i%
    i%=int((100*P%)/NMax%)
    caption 0,"Image >> Data  [ "+file_extract_name$(file$)+" ] Convertion : "+str$(i%)+" %"
end_sub

' ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

Sub Enregistrer()
  dim_local a$,b$
  Save_dialog 500
  filter 500,"*.bas|*.bas"
  a$=file_name$(500)
  b$="_bmp.bas"
  if right$(a$,8)<>b$:a$=a$+b$:end_if
  file_save mem%,a$
End_Sub