Struggle with forum software (IE). Part 2

[Wayne Diamond]

'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

   #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

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

[Semen Matusovski]

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.

   ' 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).]

[Semen Matusovski]

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]