drag'n'drop file problem

[Frankolinox]

hello all. I've done this little drag and drop (for files) example but something is missing there. any idea? the example doesn't work correct.

Code: [Select]

 $ filename "t.exe"
  '#include "../../inc/RTL32.inc"
  '#include "../../inc/RTL64.inc"
  #include "../../inc/MinWin.inc"


  #lookahead ' for procedures
  s=error()
  '
  if s then
    print s
    end
  end if

Declare Function DragQueryFile Lib "shell32" Alias "DragQueryFileA" ( _
    ByVal wHandle As SYS, _
    ByVal NumFiles As SYS, _
    ByVal NameBuffer As SYS, _
    ByVal BufferLen As Long) As SYS

DECLARE SUB DragAcceptFiles LIB "SHELL32.DLL" ALIAS "DragAcceptFiles" ( _
   BYVAL hWnd AS SYS _                                ' __in HWND hWnd
 , BYVAL fAccept AS SYS _                              ' __in BOOL fAccept
 )                                                      ' void

Declare Sub DragFinish Lib "shell32" Alias "DragFinish" (ByVal wHandle As Long)

'%WM_DROPFILES        = &H0233???
%WM_DROPFILES        = &H233


  '=========
  'MAIN CODE
  '=========
  
  dim cmdline as asciiz ptr, inst as sys
  &cmdline=GetCommandLine
  inst=GetModuleHandle 0
  '
  'WINDOWS START
  '=============
  '
  WinMain inst,0,cmdline,SW_NORMAL
  end


  '--------------------------------------------------------------------
  Function WinMain(sys inst, prevInst, asciiz*cmdline, sys show) as sys
  '====================================================================


  WndClass wc
  MSG      wm

  sys hwnd, wwd, wht, wtx, wty, tax

  wc.style = CS_HREDRAW or CS_VREDRAW
  wc.lpfnWndProc = @WndProc
  wc.cbClsExtra =0
  wc.cbWndExtra =0    
  wc.hInstance =inst
  wc.hIcon=LoadIcon 0, IDI_APPLICATION
  wc.hCursor=LoadCursor 0,IDC_ARROW
  wc.hbrBackground = GetStockObject WHITE_BRUSH
  wc.lpszMenuName =null
  wc.lpszClassName = strptr "Demo"

  RegisterClass (@wc)
 
  Wwd = 320 : Wht = 200
  Tax = GetSystemMetrics SM_CXSCREEN
  Wtx = (Tax - Wwd) /2
  Tax = GetSystemMetrics SM_CYSCREEN
  Wty = (Tax - Wht) /2
 
  hwnd = CreateWindowEx 0,wc.lpszClassName,"Drag'n Drop File Test",WS_OVERLAPPEDWINDOW,Wtx,Wty,Wwd,Wht,0,0,inst,0
  ShowWindow hwnd,SW_SHOW
  UpdateWindow hwnd
  '
  sys bRet
  '
  do while bRet := GetMessage (@wm, 0, 0, 0)
    if bRet = -1 then
      'show an error message
    else
      TranslateMessage @wm
      DispatchMessage @wm
    end if
  wend

  End Function



  dim as rect crect 'for WndProc and TimerProc

  '--------------------------------------------------------------
  function WndProc ( sys hWnd, wMsg, wParam, lparam ) as sys callback
  '==============================================================

    static as sys hdc
    static as String txt,cr
    string sFiles
    sys pDrop
    static as PaintStruct Paintst
 
    '==========
    select wMsg
    '==========
        
      '--------------
      case WM_CREATE
      '=============

      GetClientRect  hWnd,&cRect
      
      CASE WM_DROPFILES
            pDrop = wparam              
              sFiles=myDragFiles(pDrop)
              DragFinish(wparam)
              print "drag test"

      '--------------  
      case WM_DESTROY
      '===============
      DragAcceptFiles hWnd, TRUE
      PostQuitMessage 0
        
      '------------
      case WM_PAINT
      '============


      'TEXT
      'http://msdn.microsoft.com/en-us/library/dd144821(v=VS.85).aspx

      'DRAWING AND PAINTING
      'http://msdn.microsoft.com/en-us/library/dd162760(v=VS.85).aspx

      GetClientRect  hWnd,&cRect
      hDC=BeginPaint hWnd,&Paintst
      'style
      '0x20 DT_SINGLELINE
      '0x04 DT_VCENTER
      '0x01 DT_CENTER
      '0x25

       SetBkColor   hdc,yellow
       SetTextColor hdc,red
       DrawText hDC,"Hello World!",-1,&cRect,0x25
       EndPaint hWnd,&Paintst
        
      '--------------  
      case WM_KEYDOWN
      '==============

      '============            
      Select wParam
      '============

Case 27 : SendMessage hwnd, WM_CLOSE, 0, 0      'ESCAPE

      End Select
      

      '--------        
      case else
      '========
          
        function=DefWindowProc hWnd,wMsg,wParam,lParam
        
    end select

  end function ' WndProc
  
  '
  '----------------------------------------------------
  function mydragfiles (byval hDropParam as sys) as string
  '----------------------------------------------------
  
  sys i,retval 'hDropParam,
  string sDropFiles,sFile,s
  sDropFiles=""

for i = 0 to DragQueryFile(hDropParam, &HFFFFFFFF&, "", 0)-1
      sFile = SPACE(DragQueryFile(hDropParam, i, "", 0)+1)
      'DragQueryFile hDropParam, i, BYVAL STRPTR(sFile), LEN(sFile)
      DragQueryFile hDropParam, i, str(sFile), LEN(sFile)
      sFile = LEFT(sFile, LEN(sFile)-1)
      'UCASE(RIGHT(sFile,4)) as command doesn't exist!
      IF UCASE(LEFT(sFile, 4)) = ".LNK" THEN sFile = ""
      'IF UCASE(RIGHT(sFile, 4)) = ".LNK" THEN sFile = "" 'GetLinkInfo(sFile, 1)
      sDropFiles = sDropFiles + sFile '+ "|"
next
print "test here!"


'retval=RTRIM(sDropFiles)

function=RTRIM(sDropFiles)

END FUNCTION


regards, frank

X

[Frankolinox]

I have the solution: only one line was missing!!! in winmain part

Code: [Select]

DragAcceptFiles(hwnd, TRUE)
oxygen drag example:

Code: [Select]

 $ filename "t.exe"
  '#include "../../inc/RTL32.inc"
  '#include "../../inc/RTL64.inc"
  #include "../../inc/MinWin.inc"


  #lookahead ' for procedures
  s=error()
  '
  if s then
    print s
    end
  end if

  '%WM_DROPFILES        = &H0233???
  '%WM_DROPFILES        = &H233
  % WM_DROPFILES        = 0x0233
  
  Dim myDroppedFiles(10) As String
  
  Declare Function DragQueryFile Lib "shell32" Alias "DragQueryFileA" ( _
    ByVal wHandle As sys, _
    ByVal NumFiles As sys, _
    ByVal NameBuffer As sys, _
    ByVal BufferLen As Long) As sys
 
Declare Sub DragFinish Lib "shell32" Alias "DragFinish" (ByVal wHandle As Long)

DECLARE SUB DragAcceptFiles LIB "shell32.DLL" ALIAS "DragAcceptFiles" ( _
   BYVAL hWnd AS SYS _                                ' __in HWND hWnd
 , BYVAL fAccept AS LONG _                              ' __in BOOL fAccept
 )                                                      ' void

  '=========
  'MAIN CODE
  '=========
  
  dim cmdline as asciiz ptr, inst as sys
  &cmdline=GetCommandLine
  inst=GetModuleHandle 0
  '
  'WINDOWS START
  '=============
  '
  WinMain inst,0,cmdline,SW_NORMAL
  end

  '--------------------------------------------------------------------
  Function WinMain(sys inst, prevInst, asciiz*cmdline, sys show) as sys
  '====================================================================


  WndClass wc
  MSG      wm

  sys hwnd, wwd, wht, wtx, wty, tax

  wc.style = CS_HREDRAW or CS_VREDRAW
  wc.lpfnWndProc = @WndProc
  wc.cbClsExtra =0
  wc.cbWndExtra =0    
  wc.hInstance =inst
  wc.hIcon=LoadIcon 0, IDI_APPLICATION
  wc.hCursor=LoadCursor 0,IDC_ARROW
  wc.hbrBackground = GetStockObject WHITE_BRUSH
  wc.lpszMenuName =null
  wc.lpszClassName = strptr "Demo"

  RegisterClass (@wc)
 
  Wwd = 420 : Wht = 300
  Tax = GetSystemMetrics SM_CXSCREEN
  Wtx = (Tax - Wwd) /2
  Tax = GetSystemMetrics SM_CYSCREEN
  Wty = (Tax - Wht) /2
 
  hwnd = CreateWindowEx 0,wc.lpszClassName,"drag and Drop Test_go!",WS_OVERLAPPEDWINDOW,Wtx,Wty,Wwd,Wht,0,0,inst,0
  ShowWindow hwnd,SW_SHOW
  UpdateWindow hwnd
  
  '---------------------------- this line is IMPORTANT ! ------
  DragAcceptFiles(hwnd, TRUE)
  '---------------------------- this line is IMPORTANT ! ------
  
  '
  sys bRet
  '
  do while bRet := GetMessage (@wm, 0, 0, 0)
    if bRet = -1 then
      'show an error message
    else
      TranslateMessage @wm
      DispatchMessage @wm
    end if
  wend

  End Function

Function Alternative_GetDropFiles(ByVal hDropParam As SYS) As String
  Local sDropFiles As String, sFile As String, i As Long

  for i = 1 To DragQueryFile(hDropParam, &HFFFFFFFF&, "", 0)-1
      sFile = space(DragQueryFile(hDropParam, i, "", 0)+1)              
      'sFile = SPACE$(DragQueryFile(hDropParam, i, "", 0)+1)
      'DragQueryFile(hDropParam, i, ByVal StrPtr(sFile), Len(sFile))
      DragQueryFile(hDropParam, i, StrPtr(sFile), Len(sFile))
      sFile = LEFT$(sFile, Len(sFile)-1)
      ' RIGHT(sFile,4) doesn't exists
      If Ucase(LEFT$(sFile, 4)) = ".LNK" Then sFile = "" 'GetLinkInfo(sFile, 1)
      sDropFiles = sDropFiles + sFile + "|"
  next i  
  
  FUNCTION = RTrim(sDropFiles) ', "|")
  
End Function


  dim as rect crect 'for WndProc and TimerProc

  '--------------------------------------------------------------
  function WndProc ( sys hWnd, wMsg, wParam, lparam ) as sys callback
  '==============================================================

    static as sys hdc
    static as String txt
    static as PaintStruct Paintst
 
    '==========
    select wMsg
    '==========
      
      'case WM_COMMAND
                
      '--------------
      case WM_CREATE
      '=============
            mbox "here I am"
            
            Case WM_DROPFILES
            mbox "here I am after dropfiled"
            '
            'test one
            '
            pDrop = wparam 'CBWPARAM
            sFiles = Alternative_GetDropFiles(pDrop)
              ' Free handle...
            DragFinish(wparam)
            '
            'test two
            '            
            If Alternative_GetDropFiles(wparam) Then "" 'myListDroppedFiles(1)
            DragFinish (wparam)            
            mbox "test: here's to drag something"
            'MessageBox hwnd, "Files dropped onto the dialog: " + $CRLF + $CRLF + sFiles, "frankos_dragDrop_test", %MB_ICONINFORMATION
 
      '--------------  
      case WM_DESTROY
      '===============
          
      PostQuitMessage 0
      DragAcceptFiles(hwnd, TRUE)  
      
      '------------
      case WM_PAINT
      '============


      'TEXT
      'http://msdn.microsoft.com/en-us/library/dd144821(v=VS.85).aspx

      'DRAWING AND PAINTING
      'http://msdn.microsoft.com/en-us/library/dd162760(v=VS.85).aspx

      GetClientRect  hWnd,&cRect
      hDC=BeginPaint hWnd,&Paintst
      'style
      '0x20 DT_SINGLELINE
      '0x04 DT_VCENTER
      '0x01 DT_CENTER
      '0x25

       SetBkColor   hdc,yellow
       SetTextColor hdc,red
       DrawText hDC,"Hello World!",-1,&cRect,0x25
       EndPaint hWnd,&Paintst
                          
      '--------------  
      case WM_KEYDOWN
      '==============

      '============            
      Select wParam
      '============

Case 27 : SendMessage hwnd, WM_CLOSE, 0, 0      'ESCAPE

      End Select
      

      '--------        
      case else
      '========
          
        function=DefWindowProc hWnd,wMsg,wParam,lParam
        
    end select

  end function ' WndProc


'print "test ok"
this example works as it should. you can drag a folder onto dialog and you can see the mouse with a plus sign. that's all for this example.

2)  the command  "RIGHT$" is here still missing for oxygen

3) sometimes oxygen doesn't like  "FOR" in capitals so I am prefering always "for" ... "next"


best regards, frank


X

[Charles Pegge]

Thank you Frank, we could certainly use a drag and drop example. I will have a look when I get a moment to spare.

with regard to capitalised 'FOR', you will find that some OxygenBasic examples are partially case sensitive, so that they can use C headers. using #case capital causes fully-upper-case words to be distinguished from mixed-case words.

I may adopt right as a standard macro. It is derived from mid

macro right(s,i) mid(s,-i)

print right("hello",2) 'lo

Charles