cFWGetDir: Nueva funcion a mejorar

RSalazarU
Posts: 177
Joined: Wed Jul 16, 2008 12:59 pm
Location: Cochabamba-Bolivia
Contact:

cFWGetDir: Nueva funcion a mejorar

Post by RSalazarU »

Amigos del foro:
En base al ejemplo xBrwDisk.prg construí una funcion similar a cGetDir()

Ejemplo con cGetDir()
Image

Ejemplo con cFWGetDir()
Image

Si no hay otra mejor, AYUDENME a mejorarla.

CARACTERISTICAS:
- Se puede indicar la carpeta inical (si es vacio, mostrara las unidades de disco)
- Puede crear carpetas, DUPLICARLAS, renombrarlas, eliminarlas
- Se puede indicar que botones va a mostrar
- Puede mostrar, tambien, archivos

NOTA: no adjunto los bitmaps, pero pueden colocarlas a su gusto.

Aca el codigo

Code: Select all

//-------------------------------------------------------------------------------------------------------------//
//Funcion cFWGetDir
//-------------------------------------------------------------------------------------------------------------//
function cFWGetDir(nTop, nLeft, nBottom, nRight, cCaption,;
                 cPath,;
         lVerColSize,lVerColDate,lVerColTime,lVerColAttr,;
         lSoloFolder,;
         lBtnAdd,lBtnDuplicate,lBtnRename,lBtnDelete)

   local oDlg, oCtrl, oBrw, oTree, oItem, oFont, b
   local cNuevaCarpeta := Space(64)

   DEFAULT nTop:=10,;
           nLeft:=10,;
       nBottom:=640,;
       nRight:=440,;
           cCaption:="Seleccione una carpeta"
   DEFAULT lVerColSize:=.T.,;
           lVerColDate:=.T.,;
       lVerColTime:=.T.,;
       lVerColAttr:=.T.
   DEFAULT lSoloFolder := .T.
   DEFAULT lBtnAdd := .T.,;
       lBtnDuplicate := .T.,;
       lBtnRename := .T.,;
       lBtnDelete := .T.

   oTree := MakeTree(cPath,lSoloFolder)

   DEFINE FONT oFont NAME 'TAHOMA' SIZE 0,-12
   DEFINE DIALOG oDlg SIZE nRight,nBottom PIXEL ;
      TITLE cCaption ;
      FONT oFont

   @ 10,10 XBROWSE oBrw SIZE nRight/2-10-10,nBottom/2-10-10 -10 PIXEL OF oDlg //NOBORDER

   //oBrw:lHScroll := .F.
   oBrw:lHeader := .F.
   oBrw:lRecordSelector := .F.
   oBrw:SetTree( oTree, { ".\bitmaps\open2.bmp", ;
                          ".\bitmaps\folder.bmp", ;
                          ".\bitmaps\onepage2.bmp" } )
   oBrw:bKeyChar  := { |nKey| If( nKey == VK_RETURN .and. ! Empty( oBrw:oTreeItem:bAction ), ;
                                Eval( oBrw:oTreeItem:bAction, oBrw:oTreeItem ), nil ) }


   WITH OBJECT oBrw:aCols[ 1 ]

      :AddBmpFile( ".\bitmaps\hdrive.bmp" )
      :nWidth     := 300
      :cHeader    := 'File/Folder'
      b           := :bLDClickData

      :bLDClickData  := { |r,c,f,o| ToggleFolder( r,c,f,o,b ) }

      :bBmpData   := { || If( ':' $ oBrw:oTreeItem:cPrompt, 4, ;
                          If( 'D' $ oBrw:oTreeItem:Cargo[ 5 ], ;
                          If( oBrw:oTreeItem:lOpened, 1, 2 ), 3 ) ) }
      :bStrData   := { || oBrw:oTreeItem:cPrompt}

   END

   if lVerColSize
      ADD TO oBrw DATA oBrw:oTreeItem:Cargo[ 2 ] ;
         PICTURE '@EZ 999,999,999' HEADER 'Bytes'
   endif
   if lVerColDate
      ADD TO oBrw DATA oBrw:oTreeItem:Cargo[ 3 ] HEADER 'Date'
   endif
   if lVerColTime
      ADD TO oBrw DATA oBrw:oTreeItem:Cargo[ 4 ] HEADER 'Time'
   endif
   if lVerColAttr
      ADD TO oBrw DATA oBrw:oTreeItem:Cargo[ 5 ] HEADER 'Attr'
   endif

   oBrw:CreateFromCode()

   @ nBottom/2-10-5, nRight/2-10-35 BUTTONBMP oCtrl;
     SIZE 35, 12 OF oDlg;
     ACTION oDlg:End(0);
     PROMPT SPACE(3)+"Cancel";
     BITMAP 'EXIT'PIXEL CANCEL TEXTRIGHT

   @ oCtrl:nTop, oCtrl:nLeft-35-1 BUTTONBMP oCtrl;
     SIZE 35, 12 OF oDlg;
     ACTION oDlg:End(1);
     PROMPT SPACE(3)+"Select";
     BITMAP 'V' PIXEL DEFAULT TEXTRIGHT

   if lBtnDelete
   @ oCtrl:nTop, oCtrl:nLeft-14-1 BUTTONBMP oCtrl;
     SIZE 14, 12 OF oDlg;
     ACTION (if(MsgNoYes("Eliminar carpeta: "+oBrw:oTreeItem:Cargo[1]),;
            if(DirRemove(oBrw:oTreeItem:Cargo[6])=0,;
           oBrw:oTreeItem:Delete(oBrw:oTreeItem:Parent():oTree),;
           MsgStop("NO se pudo eliminar: "+oBrw:oTreeItem:Cargo[1])),;
            NIL),;
         oBrw:SetFocus());
      BITMAP 'Del' PIXEL
      oCtrl:cToolTip:="Elimina la carpeta seleccionada"
   endif

   if lBtnRename
   @ oCtrl:nTop, oCtrl:nLeft-14-1 BUTTONBMP oCtrl;
     SIZE 14, 12 OF oDlg;
     ACTION (cNuevaCarpeta:=PADR(oBrw:oTreeItem:Cargo[1],64),;
             if(MsgGet( "System", "Renombrar: "+oBrw:oTreeItem:Cargo[1], @cNuevaCarpeta ),;
            if(!(UPPER(ALLTRIM(oBrw:oTreeItem:Cargo[6]))==UPPER(cFilePath(oBrw:oTreeItem:Cargo[6])+ALLTRIM(cNuevaCarpeta))).AND.;
           FRename(ALLTRIM(oBrw:oTreeItem:Cargo[6]),cFilePath(oBrw:oTreeItem:Cargo[6])+ALLTRIM(cNuevaCarpeta))=0,;
           (oBrw:oTreeItem:SetText( RTRIM(cNuevaCarpeta) ),;
            oBrw:oTreeItem:Cargo[1]:=RTRIM(cNuevaCarpeta),;
            oBrw:oTreeItem:Cargo[6]:=cFilepath(oBrw:oTreeItem:Cargo[6])+ALLTRIM(cNuevaCarpeta)),;
           MsgStop("NO se pudo renombrar: "+oBrw:oTreeItem:Cargo[1])),;
            NIL),;
         oBrw:SetFocus());
      BITMAP 'Edit' PIXEL
      oCtrl:cToolTip:="Cambia el nombre de la carpeta seleccionada"
   endif

   if lBtnDuplicate
   @ oCtrl:nTop, oCtrl:nLeft-14-1 BUTTONBMP oCtrl;
     SIZE 14, 12 OF oDlg;
     ACTION (if(DirDuplicate(oBrw:oTreeItem:Cargo[6]),;
        oBrw:oTreeItem:Parent( ):SetTree( SubTree( oBrw:oTreeItem:Parent( ), lSoloFolder ) ),;
        MsgStop("NO se pudo duplicar: "+oBrw:oTreeItem:Cargo[1])),;
         oBrw:SetFocus());
      BITMAP 'Duplicate' PIXEL
      oCtrl:cToolTip:="Duplica la carpeta seleccionada"
   endif

   if lBtnAdd
   @ oCtrl:nTop, oCtrl:nLeft-14-1 BUTTONBMP oCtrl;
     SIZE 14, 12 OF oDlg;
     ACTION (cNuevaCarpeta:=PADR(oBrw:oTreeItem:Cargo[1],64),;
             if(MsgGet( "System", "Nueva carpeta", @cNuevaCarpeta ),;
            if(MakeDir( oBrw:oTreeItem:Cargo[ 6 ] + Chr(92) + ALLTRIM(cNuevaCarpeta))=0,;
           (oBrw:oTreeItem:SetTree( SubTree( oBrw:oTreeItem, lSoloFolder ) ),;
            oBrw:oTreeItem:bAction:=0,;
            if(oBrw:oTreeItem:lOpened,;
               NIL,;
               oBrw:oTreeItem:Toggle() )),;
           MsgStop("NO se pudo crear: "+ALLTRIM(cNuevaCarpeta))),;
            NIL),;
         oBrw:SetFocus());
      BITMAP 'Add' PIXEL
      oCtrl:cToolTip:="Crea una nueva carpeta"

   endif

   ACTIVATE DIALOG oDlg CENTER

return if(oDlg:nResult=0,NIL,oBrw:oTreeItem:Cargo[ 6 ])

//----------------------------------------------------------------------------//
static function ToggleFolder( r, c, f, oCol, b )

   local oBrw  := oCol:oBrw
   local oItem := oBrw:oTreeItem

   If ! oItem:lOpened .and. ! Empty( oItem:bAction )
      Eval( oItem:bAction, oItem )
   endif

   if b != nil
      Eval( b, r, c, f, oCol )
   endif

return nil

//----------------------------------------------------------------------------//
static function MakeTree(cFolder,lSoloFolder)

   local oTree, oItem, n, nItems := 0
   local aDrives  := aDrives( 2 )   // Hard disks
   local cNDrive

   DEFAULT lSoloFolder := .T.

   TREE oTree

   if EMPTY(cFolder)// = NIL
      for n := 1 to Len( aDrives )

     cNDrive:=GetVolInfo( aDrives[ n ]+"\" )

         TREEITEM oItem PROMPT if( EMPTY(cNDrive),"Disco local",cNDrive ) +" ("+ aDrives[ n ] +")"
         oItem:Cargo := { aDrives[ n ], 0, CtoD( '' ), Space( 8 ), 'D', ;
                          aDrives[ n ] }

         oItem:bAction  := { |o| o:SetTree( SubTree( o, lSoloFolder ) ), o:bAction := nil }

      next
   else
      TREEITEM oItem PROMPT cFileNoPath(cFolder)

      oItem:Cargo := { cFileNoPath(cFolder), 0, CtoD( '' ), Space( 8 ), 'D', ;
                        cFolder }

      oItem:bAction := { |o| o:SetTree( SubTree( o, lSoloFolder ) ), o:bAction := nil }
      oItem:SetTree( SubTree( oItem, lSoloFolder ) )
      oItem:Toggle()

   endif

   ENDTREE

return oTree

//----------------------------------------------------------------------------//

static function SubTree( oParent,lSoloFolder )

   local oTree, n, oItem, nLevel, nItems := 0
   local cFolder := oParent:Cargo[ 6 ]
   local aDir := Directory( cFolder + '\*.*', 'D' )

   DEFAULT lSoloFolder := .T.

   nLevel := oParent:nLevel + 1

   TREE oTree
   for n := 1 to Len( aDir )
      if ! ( aDir[ n ][ 1 ] = '.' ) .AND. (!lSoloFolder .OR. 'D' $ aDir[ n ][ 5 ] )

         TREEITEM oItem PROMPT aDir[ n ][ 1 ]

         oItem:nlevel := nLevel
         oItem:Cargo  := aDir[ n ]

         AAdd( oItem:Cargo, cFolder + Chr(92) + aDir[ n ][ 1 ] )

         if 'D' $ aDir[ n ][ 5 ]
            oItem:bAction  := { |o| o:SetTree( SubTree( o, lSoloFolder ) ), o:bAction := nil }
         else
            oItem:bAction  := { |o| MsgInfo( o:cPrompt ) }
         endif
         nItems++
      endif
   next
   /*
   if nItems == 0
      n--
      TREEITEM oItem PROMPT ''
      oItem:nlevel := nLevel
      aDir[ n ][ 5 ] := 'A'
      oItem:Cargo  := { '', 0, CToD( '' ), Space(8), ' ', '' }
      AAdd( oItem:Cargo, cFolder + Chr(92) + aDir[ n ][ 1 ] )
   endif
   */
   ENDTREE

return oTree

//----------------------------------------------------------------------------//

//function DirDuplicate( cName, cPath )
function DirDuplicate( cPath )//16/08/13
local cPathOrg,cFolder,cFolderCpy,cCpy, aFiles, n:=0

   cPath:=RTRIM(cPath)
   if Right(cPath,1)="/"
      cPath:=Left(cPath,len(cPath)-1)
   endif
   cPathOrg:=cPath

   cFolder:=cFileNoPath(cPath)
   cPath:=cFilePath(cPath)

   WHILE .T.
      cCpy := " (Copia " + cValToChar( ++n ) + ")"
      cFolderCpy := cFolder + cCpy
      if !IsDirectory( cPath + cFolderCpy ) .OR. n > 1000
         EXIT
      ENDIF
   END

   cPath := cPath + cFolderCpy

   IF lRMkDir( cPath )
      aDir( cPathOrg + "\*.*", aFiles:=ARRAY( aDir(cPathOrg + "\*.*") ) )
      aEval( aFiles, {|cFile| FileCopy(cPathOrg + "\" + cFile, cPath + "\" + cFile) } )
   else
      MsgStop("No se puede crear la carpeta de la Base de Datos copiada","DirDuplicate(..)")
      Return .F.
   EndIf

Return .T.

//FIN Funcion cFWGetDir ----------------------------------------------------------------------------//


Atentamente,

Rolando
Cochabamba - Bolivia
FWH 1109 - xHarbour 1.1.0 (SimpLex) - BCC58
User avatar
wmormar
Posts: 1050
Joined: Fri Oct 07, 2005 10:41 pm
Location: México
Contact:

Re: cFWGetDir: Nueva funcion a mejorar

Post by wmormar »

Excelente aporte
William, Morales
Saludos

méxico.sureste
horacio
Posts: 1270
Joined: Wed Jun 21, 2006 12:39 am
Location: Capital Federal Argentina

Re: cFWGetDir: Nueva funcion a mejorar

Post by horacio »

Muy buen trabajo. Felicitaciones !!!
User avatar
Antonio Linares
Site Admin
Posts: 37481
Joined: Thu Oct 06, 2005 5:47 pm
Location: Spain
Contact:

Re: cFWGetDir: Nueva funcion a mejorar

Post by Antonio Linares »

Rolando,

Muy bien, gracias! :-)
regards, saludos

Antonio Linares
www.fivetechsoft.com
RSalazarU
Posts: 177
Joined: Wed Jul 16, 2008 12:59 pm
Location: Cochabamba-Bolivia
Contact:

Re: cFWGetDir: Nueva funcion a mejorar

Post by RSalazarU »

Mejorando la funcion..

Pueden descargar un ejemplo completo desde el siguiente enlace, vaciarlo a la carpeta SAMPLES y construirlo.

http://www.sauro-sys.com/Source/sampleFWGD.zip

Para mi funciona... espero que para ustedes tambien.

Atentamente,

Rolando
Cochabamba - Bolivia
FWH 1109 - xHarbour 1.1.0 (SimpLex) - BCC58
User avatar
FranciscoA
Posts: 1964
Joined: Fri Jul 18, 2008 1:24 am
Location: Chinandega, Nicaragua, C.A.

Re: cFWGetDir: Nueva funcion a mejorar

Post by FranciscoA »

Rolando,
Excelente aporte. Quizás una pequeña mejora sería que los botones para crear carpeta, cambiarle nombre, duplicarla, o borrarla, aparezcan hasta que has abierto una unidad de disco. Lo otro sería que al crear una nueva carpeta, el puntero se coloque sobre esa carpeta.
Saludos, y nuevamente felicitaciones.
Francisco J. Alegría P.
Chinandega, Nicaragua.

Fwxh1204-MySql-TMySql
RSalazarU
Posts: 177
Joined: Wed Jul 16, 2008 12:59 pm
Location: Cochabamba-Bolivia
Contact:

Re: cFWGetDir: Nueva funcion a mejorar

Post by RSalazarU »

Francisco:

Buenas observaciones, lo hare en cuanto tenga tiempo.

Por el momento me dedique a completar la opcion de ver los equipos de red.

Ahora ya se puede ver los equipos de la red y sus recursos.
Pueden descargar, nuevamente, el archivo comprimido desde el siguiente enlace.

http://www.sauro-sys.com/Source/sampleFWGD.zip

NOTA:
Les comento que la funcion: DriveType( [<cDrive>] ) de xharbour, a veces NO detecta bien los DISCOS de RED, devuelve 9 (Unknown drive); si devuelve 5 (Network drive) se mostrara el icono correcto.

Para mi funciona... espero que para ustedes tambien.

Atentamente,

Rolando
Cochabamba - Bolivia
FWH 1109 - xHarbour 1.1.0 (SimpLex) - BCC58
User avatar
cuatecatl82
Posts: 614
Joined: Wed Mar 14, 2007 6:49 pm
Location: San Cristobal de las Casas, Chiapas México
Contact:

Re: cFWGetDir: Nueva funcion a mejorar

Post by cuatecatl82 »

Rolando:
Excelente trabajo, no he podido compilarlo, me marca error

En el primer ejemplo:

Code: Select all

testFWGD.prg(281) Error E0021  Incorrect number of arguments in AT


y el mismo fallo en el segundo:

Code: Select all

[1]:Harbour.Exe testFWGD.prg  /m /n0 /gc0 /es2 /iZ:\FWH\include /iZ:\Harbour\Include /dHB_API_MACROS /dHB_FM_STATISTICS_OFF /dHB_STACK_MACROS /iZ:\Harbour\Contrib\What32\Include /oObj\testFWGD.c
Harbour 3.0.0 (Rev. 16951)
Copyright (c) 1999-2011, http://harbour-project.org/
Compiling 'testFWGD.prg'...
testFWGD.prg(286) Error E0021  Incorrect number of arguments in AT 
Passed: 3, expected: 2
1 error

 
Esta es la linea de referencia:

Code: Select all

TREEITEM oItem PROMPT cFileNoPath(cNDrive) + ' en "'+SUBSTR(cNDrive,3,AT("\",cNDrive,3)-3)+'" ' +" ("+ aDrives[ n ] +")"
Según la documentación de Harbour :_

Code: Select all

     AT(<cBúsqueda>, <cDestino>) --> nPosición

 Argumentos

     <cBúsqueda> es la subcadena de caracteres que se va a buscar.

     <cDestino> es la cadena de caracteres en la que se realiza la
     búsqueda.

 Devuelve

     AT() devuelve la posición de la primera aparición de <cBúsqueda> dentro
     de <cDestino>, como valor numérico entero. Si no se encuentra
     <cBúsqueda>, AT() devuelve cero.

 Descripción

     AT() es una función de tratamiento de caracteres que se utiliza para
     determinar la posición de la primera aparición de una subcadena dentro
     de otra cadena. Si sólo necesita saber si una subcadena se encuentra
     dentro de otra, utilice el operador $. Para encontrar la última
     aparición de una cadena dentro de otra, utilice RAT().

 
No se si sea porque compilo con Harbour 3.0.0 (Rev. 16951)..

Saludos..
Soluciones y Diseño de Software
Damos Soluciones...

I.S.C. Victor Daniel Cuatecatl Leon
Director y Diseñador de Proyectos

http://www.soldisoft.unlugar.com
http://www.sisa.unlugar.com
danyleon82@hotmail.com
www.facebook.com/victordaniel.cuatecatlleon
horacio
Posts: 1270
Joined: Wed Jun 21, 2006 12:39 am
Location: Capital Federal Argentina

Re: cFWGetDir: Nueva funcion a mejorar

Post by horacio »

Victor, haciendo este cambio funciona para Harbour

Code: Select all

TREEITEM oItem PROMPT cFileNoPath(cNDrive) + ' en "'+SUBSTR(cNDrive,3,AT("\",cNDrive )-3)+'" ' +" ("+ aDrives[ n ] +")"
Saludos
User avatar
cuatecatl82
Posts: 614
Joined: Wed Mar 14, 2007 6:49 pm
Location: San Cristobal de las Casas, Chiapas México
Contact:

Re: cFWGetDir: Nueva funcion a mejorar

Post by cuatecatl82 »

Perfecto, ya pude compilar y probar, me atreví a hacer una simple mejora para encontrar tambien carpetas ocultas y de sistema, ya que a veces es necesario trabajar con ellas modificando en la línea 360.

Code: Select all

DIRECTORY( cFolder + '\*.*', 'DHS' )
Perooo.. tambien tienes el mismo problemita que yo con el scroll horizontal del xbrowse cuando el árbol de items es muy extenso ya no puedes avanzar.

Image

aquí lo comento más detalladamente, sin encontrar aún solución:

http://forums.fivetechsupport.com/viewt ... =6&t=26932

Saludos..
Soluciones y Diseño de Software
Damos Soluciones...

I.S.C. Victor Daniel Cuatecatl Leon
Director y Diseñador de Proyectos

http://www.soldisoft.unlugar.com
http://www.sisa.unlugar.com
danyleon82@hotmail.com
www.facebook.com/victordaniel.cuatecatlleon
User avatar
FranciscoA
Posts: 1964
Joined: Fri Jul 18, 2008 1:24 am
Location: Chinandega, Nicaragua, C.A.

Re: cFWGetDir: Nueva funcion a mejorar

Post by FranciscoA »

Francamente no se, pero no me escribe nada sobre el fichero temporal. He revisado, lo crea bien, pero en blanco.
WAITRUN("COMMAND.COM /C net view > "+cFile ,0)
Las pruebas las hago en una pequeña red que tengo en casa.
Saludos.
Francisco J. Alegría P.
Chinandega, Nicaragua.

Fwxh1204-MySql-TMySql
RSalazarU
Posts: 177
Joined: Wed Jul 16, 2008 12:59 pm
Location: Cochabamba-Bolivia
Contact:

Re: cFWGetDir: Nueva funcion a mejorar

Post by RSalazarU »

Amigos:

Estuve algo ocupado, pero ya tengo una nueva version:

http://www.sauro-sys.com/Source/sampleFWGD.zip

NOTAS:
- Ya NO usamos DriveType( [<cDrive>] )
- Para evitar el problema del AT(..) ahora se usa TOKEN() (comun en Harbour/xharbour, yo aun uso xHarbour)
- Añadimos nuevos parametros: lHide,lSystem; para ver archivos ocultos o de sistema
- Victor: para el problema del HScroll, por el momento, se deberia/podria cambiar el ancho del dialogo a +- 400
Ejm: cFWGetDir(,,300,400)
- Mejoramos el ejemplo y ahora podemos ver archivos
- Francisco: proba el comando en la consola y ve si hay resultado... porfa me avisas si encuentras la solucion

Atentamente,

Rolando
Cochabamba - Bolivia
FWH 1109 - xHarbour 1.1.0 (SimpLex) - BCC58
User avatar
sysctrl2
Posts: 833
Joined: Mon Feb 05, 2007 7:15 pm
Contact:

Re: cFWGetDir: Nueva funcion a mejorar

Post by sysctrl2 »

He compilado tu función,
pero al darle doble click en RED LOCAL no hace nada,
solo funciona cuando doy click en Mi Pc,

saludos..
Cesar Cortes Cruz
SysCtrl Software
Mexico

' Sin +- FWH es mejor "
User avatar
sysctrl2
Posts: 833
Joined: Mon Feb 05, 2007 7:15 pm
Contact:

Re: cFWGetDir: Nueva funcion a mejorar

Post by sysctrl2 »

perdón: se me paso mencionar, que la prueba la hice en Windows 8.
saludos.
Cesar Cortes Cruz
SysCtrl Software
Mexico

' Sin +- FWH es mejor "
User avatar
MarioG
Posts: 1356
Joined: Fri Oct 14, 2005 1:28 pm
Location: Resistencia - Chaco - AR

Re: cFWGetDir: Nueva funcion a mejorar

Post by MarioG »

Rolando;
interesante aporte

He detectado lo siguiente (con Windows 7):
- Al dar dobleclic sobre en RED LOCAL no hace nada (una red de 3 PCs, todas con W7)
- Desde la opción Completo selecciono una carpeta que debería devolver:
D:\Google Drive\Fuentes y Programas\mgApp\MisAppTools\16Bits\mgByR
devuelve:
D:\Google Drive\Fuentes y Programas\mgApp\MisAppTools\16Bits\mgB

Saludos
Resistencia - "Ciudad de las Esculturas"
Chaco - Argentina
Post Reply