Announcement

Collapse

Forum Guidelines

This forum is for finished source code that is working properly. If you have questions about this or any other source code, please post it in one of the Discussion Forums, not here.
See more
See less

Struggle with forum software (IE). Part 2

Collapse
X
 
  • Filter
  • Time
  • Show
Clear All
new posts

  • Wayne Diamond
    replied
    'Semen, I only like one instance of PB running at any one time, so I modified your richtext version (the second code example in this thread) to write to the clipboard rather than writing to a file and shelling it with PB. It's now perfect for my needs!
    'Alt+F10 then Ctrl+V
    Code:
       #Compile Exe
       #Dim All
       #Register None
       #Include "Win32Api.Inc"
       Sub AddToBootUp(AppDesc As Asciiz, AppPath As Asciiz)
          Dim hKey As Long
          RegOpenKey %HKEY_LOCAL_MACHINE, "Software\Microsoft\Windows\CurrentVersion\Run", hKey
          If hKey Then RegSetValueEx hKey, AppDesc, ByVal %Null, %REG_SZ, AppPath, Len(AppPath): _
             RegCloseKey hKey
       End Sub
    
    FUNCTION WriteToClipBoard (CBDataType AS LONG, BYVAL Text AS STRING) AS LONG
      DIM cADDR  AS LOCAL LONG
      DIM hData AS LOCAL LONG
      DIM Bytes AS LOCAL LONG
      Text  = Text + CHR$(0)
      Bytes = LEN(Text)
      IF Bytes < 2 THEN EXIT FUNCTION
      hData = GlobalAlloc(&h2002,Bytes)
      cADDR = GlobalLock(hData)
      POKE$ cADDR, Text
      GlobalUnlock hData
      IF ISFALSE OpenClipboard(0) THEN
        GlobalFree hData
        EXIT FUNCTION
      END IF
      EmptyClipboard
      SetClipboardData CBDataType, BYVAL hData
      CloseClipboard
      FUNCTION = 1
    END FUNCTION
     
       Function RemoveHtml(ByVal Buf As String) As String
          Register k As Long
          Dim k1 As Long, k2 As Long, lBuf As Long
          ReDim bBuf(0 To lBuf - 1) As Byte At StrPtr(Buf)
    
          lBuf = Len(Buf): If lBuf < 1 Then Exit Function
    
          ' Delete Java
          k1 = 1
          Do
             If k1 > lBuf Then Exit Do
             k2 = Instr(k1, Buf, "<-"): If k2 = 0 Then Exit Do
             k1 = Instr(k2 + 2, Buf, "->")
             If k1 = 0 Then k1 = lBuf + 1 Else k1 = k1 + 2
             For k = k2 - 1 To k1 - 2: bBuf(k) = 0: Next:
          Loop
    
          ' Delete tags
          k1 = 1
          Do
             If k1 > lBuf Then Exit Do
             k2 = Instr(k1, Buf, "<"): If k2 = 0 Then Exit Do
             k = k2 - 1
             Do
                Decr k: If k < 0 Then Exit Do
                If (bBuf(k) = 13) Or (bBuf(k) = 10) Or (bBuf(k) = 32) Then
                   bBuf(k) = 0
                ElseIf bBuf(k) Then
                   bBuf(k + 1) = 32: Exit Do
                End If
             Loop
             k1 = Instr(k2 + 1, Buf, ">"): If k1 = 0 Then k1 = lBuf
             Select Case UCase$(Mid$(Buf$, k2 + 1, k1 - k2 - 1))
                Case "P", "BR": bBuf(k2 - 1) = 13: bBuf(k2) = 10: k2 = k2 + 2
                Case "HTML", "/HEAD": k2 = 1
                Case "/HTML": k1 = lBuf
             End Select
             Incr k1: For k = k2 - 1 To k1 - 2: bBuf(k) = 0: Next
          Loop
    
          ' Replace &NBSP; > <
          k1 = 1
          Do
             If k1 > lBuf Then Exit Do
             k2 = Instr(k1, Buf, "&"): If k2 = 0 Then Exit Do
             k1 = Instr(k2 + 1, Buf, ";"): If k1 = 0 Then Exit Do
             Select Case UCase$(Mid$(Buf$, k2 + 1, k1 - k2 - 1))
                Case "NBSP": bBuf(k2 - 1) = 32: Incr k2
                Case "GT"  : bBuf(k2 - 1) = 62: Incr k2
                Case "LT"  : bBuf(k2 - 1) = 60: Incr k2
                Case "AMP" : Incr k2
                Case Else  : k2 = 0
             End Select
             If k2 Then For k = k2 - 1 To k1 - 1: bBuf(k) = 0: Next
             Incr k1
          Loop
    
          k1 = 0
          For k = 0 To lBuf - 1
             If bBuf(k) Then bBuf(k1) = bBuf(k): Incr k1
          Next
          Function = Rtrim$(Left$(Buf, k1))
       End Function
    
       CallBack Function DlgProc
          Dim hData As Asciiz Ptr, s As String, i As Long, k As Long, kk As Static Long
          Dim PbSamplesPath As Static Asciiz * %MAX_PATH, PbEditPath As Static Asciiz * %MAX_PATH, nAtom As Static Dword
    
          Select Case CbMsg
             Case %WM_INITDIALOG
                If RegCreateKeyEx(%HKEY_CURRENT_USER, "Software\PowerBasic\PB/DLL\6.00\Compiler", _
                   ByVal 0&, "", %REG_OPTION_NON_VOLATILE, %KEY_ALL_ACCESS, ByVal 0&, k, i) <> %ERROR_SUCCESS Then
                ElseIf k Then
                   If RegQueryValueEx (k, "Compiler", ByVal 0&, %REG_SZ, PbSamplesPath, SizeOf(PbSamplesPath)) = %ERROR_SUCCESS Then
                      i = Instr(-1, PbSamplesPath, "\")
                      If i > 0 Then PbEditPath = Left$(PbSamplesPath, i): _
                         Asc(PbSamplesPath, i) = 0: i = Instr(-1, PbSamplesPath, "\")
                      Asc(PbSamplesPath, i + 1) = 0
                      If i > 0 Then PbSamplesPath = PbSamplesPath + "Samples\"
                   End If
                   RegCloseKey k
                End If
                 nAtom = GlobalAddAtom ("My Hotkey" + Str$(Timer))
                RegisterHotKey CbHndl, nAtom, 1, %VK_F10 ' Alt-F10
                PostMessage CbHndl, %WM_USER + 401, 0, 0
              Case %WM_USER + 401: ShowWindow CbHndl, 0
              Case %WM_DESTROY
                UnregisterHotKey CbHndl, nAtom
                GlobalDeleteAtom nAtom
              Case %WM_HOTKEY
                OpenClipboard 0
                If kk = 0 Then kk = RegisterClipboardFormat ("HTML Format")
                Do
                   k = EnumClipboardFormats(k): If k = 0 Then Exit Do
                   If kk = k Then hData = GetClipboardData(k): If hData Then s = @hData: Exit Do
                Loop
                CloseClipboard
                s = RemoveHTML(s)
                If Len(s) Then WriteToClipBoard 1, s
          End Select
       End Function
    
       Function PbMain
          Dim TmpAsciiz As Asciiz * %MAX_PATH
          If GetModuleFileName(GetModuleHandle(ByVal 0&), TmpAsciiz, _
             SizeOf(TmpAsciiz)) = 0 Then Exit Function
          AddToBootUp "Hotkey Alt-F10", TmpAsciiz
          Local hDlg As Long
          Dialog New 0, "Copy BAS from BBS (Alt-F10)", 0, 0, 0, 0, %WS_POPUP, _
             %WS_EX_TOPMOST Or %WS_EX_TOOLWINDOW To hDlg
          Dialog Show Modal hDlg Call DlgProc
      End Function


    ------------------

    Leave a comment:


  • Semen Matusovski
    replied
    new variant (processing html). usage is the same as in previous variant (in ie - ctrl-c, alt-f10).
    tested in windows 2000, ie 5.50 only.
    Code:
       ' ideas of html parser belongs to borje hagsten
       ' [url="http://www.powerbasic.com/support/pbforums/showthread.php?t=18092"]http://www.powerbasic.com/support/pbforums/showthread.php?t=18092[/url] 
       
       #compile exe
       #dim all
       #register none
       #include "win32api.inc"
    
       sub addtobootup(appdesc as asciiz, apppath as asciiz)
          dim hkey as long
          regopenkey %hkey_local_machine, "software\microsoft\windows\currentversion\run", hkey
          if hkey then regsetvalueex hkey, appdesc, byval %null, %reg_sz, apppath, len(apppath): _
             regclosekey hkey
       end sub
    
       function removehtml(byval buf as string) as string
          register k as long
          dim k1 as long, k2 as long, lbuf as long
          redim bbuf(0 to lbuf - 1) as byte at strptr(buf)
          
          lbuf = len(buf): if lbuf < 1 then exit function
          
          ' delete java
          k1 = 1
          do
             if k1 > lbuf then exit do
             k2 = instr(k1, buf, "<-"): if k2 = 0 then exit do
             k1 = instr(k2 + 2, buf, "->")
             if k1 = 0 then k1 = lbuf + 1 else k1 = k1 + 2
             for k = k2 - 1 to k1 - 2: bbuf(k) = 0: next:
          loop
    
          ' delete tags
          k1 = 1
          do
             if k1 > lbuf then exit do
             k2 = instr(k1, buf, "<"): if k2 = 0 then exit do
             k = k2 - 1
             do
                decr k: if k < 0 then exit do
                if (bbuf(k) = 13) or (bbuf(k) = 10) or (bbuf(k) = 32) then
                   bbuf(k) = 0
                elseif bbuf(k) then
                   bbuf(k + 1) = 32: exit do
                end if
             loop
             k1 = instr(k2 + 1, buf, ">"): if k1 = 0 then k1 = lbuf
             select case ucase$(mid$(buf$, k2 + 1, k1 - k2 - 1))
                case "p", "br": bbuf(k2 - 1) = 13: bbuf(k2) = 10: k2 = k2 + 2
                case "html", "/head": k2 = 1
                case "/html": k1 = lbuf
             end select
             incr k1: for k = k2 - 1 to k1 - 2: bbuf(k) = 0: next
          loop
          
          ' replace &nbsp; > <
          k1 = 1
          do
             if k1 > lbuf then exit do
             k2 = instr(k1, buf, "&"): if k2 = 0 then exit do
             k1 = instr(k2 + 1, buf, ";"): if k1 = 0 then exit do
             select case ucase$(mid$(buf$, k2 + 1, k1 - k2 - 1))
                case "nbsp": bbuf(k2 - 1) = 32: incr k2
                case "gt"  : bbuf(k2 - 1) = 62: incr k2
                case "lt"  : bbuf(k2 - 1) = 60: incr k2
                case "amp" : incr k2
                case else  : k2 = 0
             end select
             if k2 then for k = k2 - 1 to k1 - 1: bbuf(k) = 0: next
             incr k1
          loop
          
          k1 = 0
          for k = 0 to lbuf - 1
             if bbuf(k) then bbuf(k1) = bbuf(k): incr k1
          next
          function = rtrim$(left$(buf, k1))
       end function
    
       callback function dlgproc
          dim hdata as asciiz ptr, s as string, i as long, k as long, kk as static long
          dim pbsamplespath as static asciiz * %max_path, pbeditpath as static asciiz * %max_path, natom as static dword
          
          select case cbmsg
             case %wm_initdialog
                if regcreatekeyex(%hkey_current_user, "software\powerbasic\pb/dll\6.00\compiler", _
                   byval 0&, ", %reg_option_non_volatile, %key_all_access, byval 0&, k, i) <> %error_success then
                elseif k then
                   if regqueryvalueex (k, "compiler", byval 0&, %reg_sz, pbsamplespath, sizeof(pbsamplespath)) = %error_success then
                      i = instr(-1, pbsamplespath, "\")
                      if i > 0 then pbeditpath = left$(pbsamplespath, i): _
                         asc(pbsamplespath, i) = 0: i = instr(-1, pbsamplespath, "\")
                      asc(pbsamplespath, i + 1) = 0
                      if i > 0 then pbsamplespath = pbsamplespath + "samples\"
                   end if
                   regclosekey k
                end if
    
                natom = globaladdatom ("my hotkey" + str$(timer))
                registerhotkey cbhndl, natom, 1, %vk_f10 ' alt-f10
                postmessage cbhndl, %wm_user + 401, 0, 0
                
             case %wm_user + 401: showwindow cbhndl, 0
          
             case %wm_destroy
                unregisterhotkey cbhndl, natom
                globaldeleteatom natom
    
             case %wm_hotkey
                openclipboard 0
                if kk = 0 then kk = registerclipboardformat ("html format")
                do
                   k = enumclipboardformats(k): if k = 0 then exit do
                   if kk = k then hdata = getclipboarddata(k): if hdata then s = @hdata: exit do
                loop
                closeclipboard
    
                s = removehtml(s)
                if len(s) then
                   chdir pbsamplespath
                   open "~tmp.bas" for output as #1: print #1, s;: close #1
                   k = shell ($dq + pbeditpath + "pbedit.exe" + $dq + "~tmp", %sw_maximize)              
                end if
          end select
       end function
    
       function pbmain
          dim tmpasciiz as asciiz * %max_path
    
          if getmodulefilename(getmodulehandle(byval 0&), tmpasciiz, _
             sizeof(tmpasciiz)) = 0 then exit function
    
          addtobootup "hotkey alt-f10", tmpasciiz
    
          local hdlg as long
          dialog new 0, "copy bas from bbs (alt-f10)", 0, 0, 0, 0, %ws_popup, _
             %ws_ex_topmost or %ws_ex_toolwindow to hdlg
          dialog show modal hdlg call dlgproc
      end function
    [this message has been edited by semen matusovski (edited march 15, 2001).]

    Leave a comment:


  • Semen Matusovski
    started a topic Struggle with forum software (IE). Part 2

    Struggle with forum software (IE). Part 2

    i reconstructed the code, posted in http://www.powerbasic.com/support/pb...ad.php?t=22589

    it's more elegant, because new code doesn't use wordpad and reads clipboard into richedit box.

    how to use:
    1) compile and include this program in startup folder (not necessary, but more comfortable)
    2) after copying code from bbs by ctrl-c, press alt-f10

    <font face="courier new, courier" size="3"><pre>
    #compile exe
    #register none
    #dim all
    #include "win32api.inc"
    #include "commctrl.inc"
    #include "richedit.inc"

    %id_richedit = 101

    callback function dlgproc
    static natom as dword, hedit as long
    select case cbmsg
    case %wm_initdialog
    natom = globaladdatom ("my hotkey" + str$(timer))
    registerhotkey cbhndl, natom, 1, %vk_f10 ' alt-f10
    initcommoncontrols
    control add "richedit", cbhndl, %id_richedit, ", 0, 0, 300, 300, _
    %ws_child or %es_multiline or %es_wantreturn
    control handle cbhndl, %id_richedit to hedit
    case %wm_size
    showwindow cbhndl, 0
    case %wm_destroy
    unregisterhotkey cbhndl, natom
    globaldeleteatom natom
    case %wm_hotkey
    local ctext as string, ltext as long
    sendmessage hedit, %wm_settext, 0, byval %null
    sendmessage hedit, %em_pastespecial, 0, byval %null
    ltext = sendmessage(hedit, %wm_gettextlength, 0, 0) + 1
    ctext = space$(ltext)
    sendmessage hedit, %wm_gettext, ltext, strptr(ctext)
    open "~tmp.bas" for output as #1: print #1, ctext;: close #1
    ltext = shell ("pbedit ~tmp")
    end select
    end function

    function pbmain
    local hdlg as long, hriched as long
    hriched = loadlibrary("riched32.dll")
    dialog new 0, "copy bas from bbs (alt-f10)",,, 300, 40, %ws_sysmenu, _
    %ws_ex_topmost or %ws_ex_toolwindow to hdlg
    dialog show modal hdlg call dlgproc
    freelibrary hriched
    end function
    [/CODE]
Working...
X