Somerick | Дата: Суббота, 27.08.2016, 03:21 | Сообщение # 1 |
Рядовой
Группа: Пользователи
Сообщений: 14
Статус: Offline
| Может я не знаю такой функции, плохо гуглил а она есть где-то в апи винде или в срт.
Сделал свои. Какая ещё альтернатива: подключать какие-то библиотеки с регулярными выражениями. Но это совсем другое, мне это не надо, нужен самый обычный поиск. Ниже три версии одной функции, каждая в скомпилированном виде занимает "всего ничего", не более килобайта, даже с учётом 512 Б таблиц.
Возврат - указатель на найденное или ноль. Параметры: s - указатель на текст где искать w - указатель на слово(слова, текст), что надо найти. if strlen(w)=0 or strlen(s)=0 return 0 Aa - если не ноль, игнорировать регистр Ww - если не ноль, искать целое слово rev - Если rev=0 поиск вперёд, s to s+strlen(s) Если rev<0 поиск назад, s+strlen(s) to s Если rev>0 поиск назад, rev to s, если rev-strlen(w)<s разумеется поиск не производится, return 0. Но не проверяется что может быть задан rev адрес слишком большой и выходить за пределы строки.
Bas версия. MegaInstrBas.bas
Код #Include Once "cmptable.bi"
Function MegaInstrBas(s As zString Ptr,w As zString Ptr,Aa As Long=0,Ww As Long=0,rev As zString Ptr=0)As zString Ptr Dim As zString Ptr p=Any,p1=Any Dim As Long x=Any,wLen=Any Dim As Byte b=IIf(aa,Cmpi_tbl(Peek(w)),Peek(w)),c=Any If b=0 Then Exit Function
If rev=0 Then'forvard p=s-1 If aa=0 Then Do:p+=1:c=Peek(p) If c=0 Then Exit Function If c=b Then If ww Then If p>s Then If Word_tbl(Peek(p-1))Then Continue Do EndIf EndIf x=1 Do:c=Peek(w+x) If c=0 Then If ww Then If Word_tbl(Peek(p+x))Then Exit Do EndIf Return p EndIf If c<>Peek(p+x)Then Exit Do x+=1 Loop EndIf Loop Else'ignore case Do:p+=1:c=Cmpi_tbl(Peek(p)) If c=0 Then Exit Function If c=b Then If ww Then If p>s Then If Word_tbl(Peek(p-1))Then Continue Do EndIf EndIf x=1 Do:c=Cmpi_tbl(Peek(w+x)) If c=0 Then If ww Then If Word_tbl(Peek(p+x))Then Exit Do EndIf Return p EndIf If c<>Cmpi_tbl(Peek(p+x))Then Exit Do x+=1 Loop EndIf Loop EndIf
Else'backvard p=w While Peek(p):p+=1:Wend wLen=p-w If rev<0 Then rev=s While Peek(rev):rev+=1:Wend EndIf rev-=wLen If rev<s Then Exit Function p=rev+1 If aa=0 Then Do:p-=1 If p<s Then Exit Function c=Peek(p) If c=b Then If ww Then If p>s Then If Word_tbl(Peek(p-1))Then Continue Do EndIf EndIf x=1 Do:c=Peek(w+x) If c=0 Then If ww Then If Word_tbl(Peek(p+x))Then Exit Do EndIf Return p EndIf If c<>Peek(p+x)Then Exit Do x+=1 Loop EndIf Loop Else'ignore case Do:p-=1 If p<s Then Exit Function c=Cmpi_tbl(Peek(p)) If c=b Then If ww Then If p>s Then If Word_tbl(Peek(p-1))Then Continue Do EndIf EndIf x=1 Do:c=Cmpi_tbl(Peek(w+x)) If c=0 Then If ww Then If Word_tbl(Peek(p+x))Then Exit Do EndIf Return p EndIf If c<>Cmpi_tbl(Peek(p+x))Then Exit Do x+=1 Loop EndIf Loop EndIf EndIf End Function
Асм версия. В циклах не используются переменные, только регистры MegaInstrAsm.bas
Код #Include Once "cmptable.bi"
Function MegaInstrAsm naked(s As zString Ptr,w As zString Ptr,Aa As Long=0,Ww As Long=0,rev As zString Ptr=0)As zString Ptr Scope #Define p_s esp+16 #Define p_w esp+20 #Define p_aa esp+24 #Define p_ww esp+28 #Define p_rev esp+32 Asm push ebx push esi push edi mov eax,[p_s] mov esi,[p_w] movzx edx,Byte Ptr[eax]' test dl,dl jz SI_exit movzx ebx,Byte Ptr[esi]' test bl,bl jz SI_exit
cmp dword Ptr[p_rev],0 jne SI_Revers cmp Byte Ptr[p_aa],dh jne SI_F_Aa
'###### StrStr & StrStrW cmp dl,bl je Str_One_w
Str_Now: inc eax mov dx,[eax]' cmp dl,bl je Str_One test dl,dl jz SI_exit test dh,dh jz SI_exit inc eax cmp dh,bl jne Str_Now
Str_One:'1 char cmp Byte Ptr[p_ww],bh je Str_One_w movzx edx,Byte Ptr[eax-1] cmp Byte Ptr[edx+Word_tbl],dh jne Str_Now
Str_One_w: Xor edi,edi
Str_Pr: inc edi mov dx,[esi+edi] test dl,dl jz Str_enOK cmp dl,[eax+edi] jne Str_Now inc edi test dh,dh jz Str_enOK cmp dh,[eax+edi] je Str_Pr jmp Str_Now
Str_enOK: cmp Byte Ptr[p_ww],bh je SI_exitOK movzx edx,Byte Ptr[eax+edi] cmp Byte Ptr[edx+Word_tbl],dh jne Str_Now jmp SI_exitOK
'###### начало StrStri & StrStriW SI_F_Aa: Xor ecx,ecx mov bl,Byte Ptr[ebx+Cmpi_tbl] cmp bl,Byte Ptr[edx+Cmpi_tbl] je Stri_One_w
Stri_Now: inc eax mov dl,[eax]' test dl,dl jz SI_exit cmp bl,Byte Ptr[edx+Cmpi_tbl] jne Stri_Now
Stri_One: cmp Byte Ptr[p_ww],bh je Stri_One_w mov dl,[eax-1]' cmp Byte Ptr[edx+Word_tbl],dh jne Stri_Now
Stri_One_w: Xor edi,edi
Stri_Pr: inc edi mov dl,[esi+edi] test dl,dl jz Stri_enOK mov dl,Byte Ptr[edx+Cmpi_tbl] mov cl,[eax+edi] cmp dl,Byte Ptr[ecx+Cmpi_tbl] je Stri_Pr jmp Stri_Now
Stri_enOK: cmp Byte Ptr[p_ww],bh je SI_exitOK mov dl,[eax+edi] cmp Byte Ptr[edx+Word_tbl],dh jne Stri_Now jmp SI_exitOK '######## конец функционала поиска в прямом направлении
SI_Revers:'StrStrRev & StrStrWRev & StrStriRev & StrStriWRev 'Далее почти до конца, до SI_exit: код для поиска в обратном. 'Если не требуется искать назад, можно уменьшить размер исключить этот код cld xor eax,eax mov edi,esi mov ecx,&h7FFFFFFE repne scasb dec edi sub edi,esi push edi
mov edi,[p_rev+4] cmp edi,eax jg short StrR_r mov edi,[p_s+4] repne scasb dec edi
StrR_r: pop ecx mov eax,[p_s] sub edi,eax cmp ecx,edi jg SI_exit'оказалось длина w > диапазона поиска
sub edi,ecx mov ebx,edi mov edi,eax add eax,ebx
movzx ebx,Byte Ptr[esi]' inc eax cmp Byte Ptr[p_aa],bh jne SI_R_Aa
'###### StrStrRev & StrStrWRev StrR_Now: dec eax cmp eax,edi jl short SI_exit cmp bl,[eax]' jne short StrR_Now
cmp Byte Ptr[p_ww],0 je StrR_One_w cmp eax,edi jle StrR_One_w movzx edx,Byte Ptr[eax-1]' cmp Byte Ptr[edx+Word_tbl],dh jne StrR_Now
StrR_One_w: Xor edx,edx
StrR_Pr: inc edx mov bh,[esi+edx] test bh,bh jz short StrR_enOK cmp bh,[eax+edx] je short StrR_Pr jmp short StrR_Now
StrR_enOK: cmp Byte Ptr[p_ww],0 je SI_exitOK movzx edx,Byte Ptr[eax+edx] cmp Byte Ptr[edx+Word_tbl],dh jne StrR_Now jmp SI_exitOK
'###### часть StrStriRev & StrStriWRev SI_R_Aa: mov bl,Byte Ptr[ebx+Cmpi_tbl] Xor ecx,ecx
StriR_Now: dec eax cmp eax,edi jl short SI_exit mov cl,[eax]' cmp bl,Byte Ptr[ecx+Cmpi_tbl] jne short StriR_Now
cmp Byte Ptr[p_ww],0 je StriR_One_w cmp eax,edi jle StriR_One_w movzx edx,Byte Ptr[eax-1] cmp Byte Ptr[edx+Word_tbl],dh jne StriR_Now
StriR_One_w: Xor edx,edx
StriR_Pr: inc edx mov cl,[esi+edx] test cl,cl jz short StriR_enOK mov bh,Byte Ptr[ecx+Cmpi_tbl] mov cl,[eax+edx] cmp bh,Byte Ptr[ecx+Cmpi_tbl] je short StriR_Pr jmp short StriR_Now
StriR_enOK: cmp Byte Ptr[p_ww],0 je SI_exitOK movzx edx,Byte Ptr[eax+edx] cmp Byte Ptr[edx+Word_tbl],dh jne StriR_Now jmp SI_exitOK 'конец кода для поиска в обратном направлении
SI_exit: Xor eax,eax SI_exitOK: pop edi pop esi pop ebx ret 20 End Asm End Scope End Function cmptable.bi
Код '1- цифры, буквы, _ Dim Shared As Const UByte Word_tbl(256)={0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,_ 0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,0,0,_ 1,0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,_ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,0,0,0,0,0,0,0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,_ 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1}
'Нижний регистр Dim Shared As Const UByte Cmpi_tbl(256)={0,1,2,3,4,5,6,7,8,32,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,_ 29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,64,97,98,99,100,_ 101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,91,92,93,94,95,96,97,98,99,100,101,_ 102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,123,124,125,126,127,128,129,130,131,132,_ 133,134,135,136,137,138,139,140,141,142,143,144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,160,161,162,163,_ 164,165,166,167,184,169,170,171,172,173,174,175,176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,224,225,226,_ 227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,224,225,_ 226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255}
Винапи версия. В таблицах не нуждается. Эта версия самая плохая, strstri таб и пробел считает за разное, в отличие от моих функций. К тому же неизвестно как поведёт себя на разных версиях винды с разными локалями. Не рекомендуется, но совсем немного короче других. MegaInstrWin.bas
Код #Include Once "windows.bi" #Include Once "win\shlwapi.bi"
Function IfWordCharPtr(s As zString Ptr)As Long Select Case Peek(s):Case 48 To 57,65 To 90,95,97 To 122,Is>191,168,184:Function=1:End Select End Function
Function MegaInstrWin(s As zString Ptr,w As zString Ptr,Aa As Long=0,Ww As Long=0,rev As zString Ptr=0)As zString Ptr Dim As zString Ptr p=Any,p1=Any Dim As Long wLen=lstrlen(w) If wLen<1 Then Exit Function
If rev=0 Then'forvard p1=s Do:p=IIf(aa,StrStrI(p1,w),StrStr(p1,w)) If ww Then If p Then If p>s Then If IfWordCharPtr(p-1)Then p1=p+1:Continue Do EndIf If IfWordCharPtr(p+wLen)Then p1=p+1:Continue Do EndIf EndIf Return p Loop
Else'backvard p1=rev-wLen+1 If p1<s Then Exit Function Do:p=StrRStrI(s,p1,w) If aa=0 Then'no If StrCmpN(p,w,wLen)Then If p>s Then p1=p-1:Continue Do Exit Function EndIf EndIf If ww Then If p Then If p>s Then If IfWordCharPtr(p-1)Then p1=p-1:Continue Do EndIf If IfWordCharPtr(p+wLen)Then If p>s Then p1=p-1:Continue Do Exit Function EndIf EndIf EndIf Return p Loop EndIf End Function
Добавлено (27.08.2016, 03:21) --------------------------------------------- Замена. Возврат - количество замен. Параметры:
src - указатель на исходный текст dst - указатель на место, куда скопировать с заменами исходный текст. Буфер должен быть соответствующего размера. В примерах ниже показано как рассчитывается. Попросту dstLen = srcLen-(w1Len*ReplaceCount)+(w2Len*ReplaceCount), сначала поиском без замены узнать число соответствий.
w1 - указатель на текст что менять w2 - указатель на текст на который менять w1
CopyIfCntMath0 - Если не найдено ни одного соответствия и этот параметр ноль, текст не копируется в dst. В прочих случаях всегда копируется. По дефолту параметр 1.
ByRef DstCharCnt - параметр для возврата функцией числа символов в буфере назначения, исключая завершающий нулевой, короче длина нового текста с произведёнными заменами.
MegaReplaceAsm.bas
Код #Include Once "MegaInstrAsm.bas"
Function MegaReplaceAsm naked(src As ZString Ptr,dst As ZString Ptr,w1 As ZString Ptr,w2 As ZString Ptr,Aa As Long=0,Ww As Long=0,CopyIfCntMath0 As Long=1,ByRef DstCharCnt As Long=0)As Long Scope #Define dstp ebp-24 #Define cnt ebp-20 #Define w1Len ebp-16 #Define RetFlag ebp-12 #Define p_src ebp+8 #Define p_dst ebp+12 #Define p_w1 ebp+16 #Define p_w2 ebp+20 #Define p_aa ebp+24 #Define p_ww ebp+28 #Define p_Cpy0 ebp+32 #Define p_dstCnt ebp+36
Asm push ebp mov ebp,esp sub esp,64 push edi push esi Xor eax,eax mov [cnt],eax mov [RetFlag],al mov edi,[p_dst]' mov [dstp],edi mov [edi],al mov edx,[p_w1] dec edx RP_l1: inc edx cmp [edx],al jne RP_l1 Sub edx,[p_w1] mov [w1Len],edx
RP_Now: push 0 push [p_ww] push [p_aa] push [p_w1] push [p_src] Call MegaInstrAsm
mov esi,[p_src] mov edi,[p_dst] test eax,eax jnz RP_OK mov Byte Ptr[RetFlag],1 mov edx,esi cmp [cnt],eax jne RP_Copy cmp [p_Cpy0],eax je RP_Copy jmp RP_exit
RP_OK: inc dword ptr[cnt]' Sub eax,esi mov ecx,eax cld push ecx shr ecx,2 rep movsd pop ecx and ecx,3 rep movsb add esi,[w1len] mov [p_src],esi mov edx,[p_w2]
RP_Copy: mov cl,[edx]' mov [edi],cl inc edx inc edi test cl,cl jnz RP_Copy dec edi mov [p_dst],edi cmp Byte Ptr[RetFlag],0 je RP_Now
RP_exit: Sub edi,[dstp]' mov eax,[p_dstCnt] mov [eax],eax'byref mov [eax],edi mov eax,[cnt]' pop esi pop edi mov esp,ebp pop ebp ret 32 End Asm End Scope End Function
Примеры вызова функций.
Консольная программа. Примеры с буферами одного размера и пример с выделяемым под нужный размер путём New - Delete.
![](http://showpic.ru/upload/270816/57c0d03363e3d.png) ExampleMegaReplace.bas
Код #Include "MegaReplaceAsm.bas"
Dim As zString*1024 buff1=Any,buff2=Any Dim As Long CntRep=Any,CntDstChar=Any,Aa=1,Ww=0
'####### Пример 1 с статическим буфером ?"String: "; "test1 test2 abcd TEST2TEST1"
CntRep=MegaReplaceAsm("test1 test2 abcd TEST2TEST1",buff1,"Test1","replace1",Aa,Ww,1,CntDstChar)
?!"Replace ignore case \"Test1\" -> \"replace1\"" ?"Result: "; buff1 '"replace1 test2 abcd TEST2replace1" ?"Replace count = "; CntRep; " Result Strlen = "; CntDstChar 'CntRep=2
'####### Пример 2 с статическим буфером ? ?"String: "; buff1 Ww=1'whole word
CntRep=MegaReplaceAsm(buff1,buff2,"Test2","replace2",Aa,Ww,1,CntDstChar)
?!"Replace ignore case and whole word \"Test2\" -> \"replace2\"" ?"Result: "; buff2 '"replace1 replace2 abcd TEST2replace1" ?"Replace count = "; CntRep; " Result Strlen = "; CntDstChar 'CntRep=1, TEST2TEST1 - тут не заменено, так как TEST2 часть, не целое слово
'####### Пример с выделяемыми буферами
Dim As zString Ptr m1=Any,m2=Any,p=Any,srcp=Any Dim As Long srcLen=1000000
m1=New Byte[srcLen+1]{Any} p=m1 ? ?"Speed Test:" ?"Start generation BIG STRING Len 50 * 20000 strcat Wait..." Dim As Double d=Timer For x As Long=1 To 20000 'генерация строки *p="test1 test2 TEST2TEST1 qwerty1234567890asfghjkl;'-" '50 p+=50 Next
?"Ok. Time: "; Timer-d'0.003 с 'А если использовать тип String и &= счёт пойдёт на минуты ?
#Define w1Len 5' len "Test1" #Define w2Len 8' len "replace1"
?!"Start search ignore case and whole word \"Test1\" Wait..." d=Timer
'узнать количество замен CntRep=0:srcp=m1 Do:p=MegaInstrAsm(srcp,"Test1",Aa,Ww,0) If p=0 Then Exit Do CntRep+=1:srcp=p+w1Len Loop ?"Ok. Count ="; CntRep ; " Time: "; Timer-d'0.006 с
'узнать какой размер будет после замены Dim As Long dstLen=srcLen-(w1Len*CntRep)+(w2Len*CntRep)
'аллокация нового буфера m2=New Byte[dstLen+1]{Any}
? ?!"Start Replace ignore case and whole word \"Test1\" -> \"replace1\" Wait..." d=Timer
'собственно копирование с заменой CntRep=MegaReplaceAsm(m1,m2,"Test1","replace1",Aa,Ww,0,dstLen)
?"Ok. Count Replace ="; CntRep ; " Time: "; Timer-d'0.007 с ?"Calculated byffers size: "; srcLen; " & "; dstLen ?"Really text size in byffers: "; Len(*m1) ; " & "; Len(*m2)'всё сходится!
? m1[1000]=0:m2[1000]=0'чтоб было показано в консоли не 1000000 и 1060000 а первые 1000. желающие могут просмотреть полностью
?"View Src: "; *m1 ? ?"View Dst: "; *m2
Delete[] m1:Delete[] m2' освобождение памяти
Sleep 'пауза, выход компиляция fbc -s console
Далее гуи приложение, на винапи создание окна, меню, акселераторов. Простейшее и лёгкое(ехе 12 КБ), но минимальные функции текстового редактора есть. Открытие файла из командной строки\пунктом меню Открыть\перетаскиванием в окно. Сохранение через меню или ctrl+s. Статусбар с инфой о строке, позиции на строке, позиции от начала, выделении(если есть) и общем размере текста. При сохранении\открытии показывается размер файла. Кнопки- поиск (с начала) f5, вперёд > f3, назад < ctrl+f3 Полезная кнопка подсчёта числа соответствий. Показывается мессаджбокс, если число не ноль - производится переход к первому найденному от начала. Кнопка замены(сразу в всём тексте), выдаётся в мессаджбоксе информация о числе замен, размере и разнице. Переход на строку, если указано число больше чем есть строк, переходит к последней. При переходе в статусе также показывается общее число строк. Убран лимит на длину текста у основного эдит контрола. ( SendMessage t, EM_LIMITTEXT, -1, 0 ) На больших файлах с тысячами замен тоже проверял, практически мгновенно заменяет. Создавал текст 264 МБ с 120000 замен ~три секунды, сохранил на диск, нормально. (Реальный предел всё же есть, он 2 ГБ, потому что код 32-битный.) У полей ввода поиска и замены стандартный лимит длины, весьма большой.
![](http://showpic.ru/upload/270816/57c0d5b1dbbed.png)
Editor.bas
Код #Include Once "windows.bi" #Include Once "win\shellapi.bi" #Include Once "win\shlwapi.bi" #Include Once "win\commdlg.bi"
#Include Once "MegaReplaceAsm.bas"
#Define MegaInstr MegaInstrAsm #Define EDITFIND 2000 #Define EDITREPLACE 2001 #Define BTNCNT 2002 #Define BTNR 2003 #Define BTNFIND 2004 #Define BTNL 2005 #Define BUTTONREPLACE 2006 #Define EDIT 2007 #Define CHECKWW 2008 #Define CHECKAA 2009 #Define BTNGOTO 2010 #Define EDITGOTO 2011 #Define MENUNEW 2500 #Define MENUOPEN 2501 #Define MENUSAVE 2502 #Define MENUSAVEAS 2503 #Define MENUEXIT 2504
#Define TbLen(t) SendMessage(t,WM_GETTEXTLENGTH,0,0) #Define TbAdd(t,s) SendMessage t,EM_REPLACESEL,1,s #Define TbSetSel(t,x,y) SendMessage t,EM_SETSEL,x,y #Define TbScroll(t) SendMessage t,EM_SCROLLCARET,0,0 Dim Shared As HWND hw,t,tf,tr,l Dim Shared As ZString*260 sFile Dim Shared As WndProc EProc
Type zMem As ZString Ptr m'указатель на память As Long ln,txtln'длина памяти,длина текста Declare Function Start(b As Long)As ZString Ptr'возврат указателя на буфер не менее b+2 байт Declare Function GetTxt(h As HWND)As ZString Ptr'возврат ук. на память с скопированным текстом из окна h Declare Sub free Declare Destructor End Type Dim Shared As zMem Txt,TxtF,TxtR,TxtBuff
Declare Function WndProc(hWin As HWND,uMsg As UINT,wParam As WPARAM,lParam As LPARAM)As Long Declare Function EditProc(h As HWND,msg As Ulong,wparam As WPARAM,lParam As LPARAM)As Long Declare Sub Find(mode As Long) Declare Sub FileLoadSave(s As ZString Ptr,mode As Long)
Sub main Cdecl Alias "main"'Entry Point Dim As WNDCLASS wc Dim As MSG msg=Any Dim As HFONT f=GetStockObject(DEFAULT_GUI_FONT) wc.hbrBackground=16 wc.hInstance=GetModuleHandle(0) wc.style=CS_PARENTDC Or CS_DBLCLKS wc.lpfnWndProc=@WndProc wc.lpszClassName=@"TestSearchAndReplace" RegisterClass @wc #Define i wc.hInstance
hw=CreateWindowEx(272,"TestSearchAndReplace","Редактор - Новый файл.txt",349110272,100,50,850,668,0,0,i,0) t=CreateWindowEx(512,"Edit","",&h503011C4,0,48,752,472,hw,EDIT,i,0) SendMessage t,WM_SETFONT,f,1 SendMessage t,EM_LIMITTEXT,-1,0'No Limit! EProc=SetWindowLong(t,-4,@EditProc) tf=CreateWindowEx(512,"Edit","",1342242944,8,8,160,30,hw,EDITFIND,i,0) SendMessage tf,WM_SETFONT,f,1 tr=CreateWindowEx(512,"Edit","",1342242944,448,8,152,30,hw,EDITREPLACE,i,0) SendMessage tr,WM_SETFONT,f,1 l=CreateWindowEx(0,"Static","",1342177408,8,600,832,24,hw,2500,i,0) SendMessage l,WM_SETFONT,f,1 SendMessage CreateWindowEx(0,"Button","Заменить",1342254848,600,8,80,32,hw,BUTTONREPLACE,i,0),WM_SETFONT,f,1 SendMessage CreateWindowEx(0,"Button","Счёт",1342254848,296,8,48,32,hw,BTNCNT,i,0),WM_SETFONT,f,1 SendMessage CreateWindowEx(0,"Button",">",1342254848,264,8,32,32,hw,BTNR,i,0),WM_SETFONT,f,1 SendMessage CreateWindowEx(0,"Button","Ww",1342242819,400,8,48,32,hw,CHECKWW,i,0),WM_SETFONT,f,1 SendMessage CreateWindowEx(0,"Button","A=a",1342242819,352,8,48,32,hw,CHECKAA,i,0),WM_SETFONT,f,1 SendMessage CreateWindowEx(0,"Button","<",1342254848,168,8,32,32,hw,BTNL,i,0),WM_SETFONT,f,1 SendMessage CreateWindowEx(0,"Button","Найти",1342254848,200,8,64,32,hw,BTNFIND,i,0),WM_SETFONT,f,1 SendMessage CreateWindowEx(512,"Edit","1",1342251136,688,8,48,30,hw,EDITGOTO,i,0),WM_SETFONT,f,1 SendMessage CreateWindowEx(0,"Button","Пер. на строку",1342254848,736,8,96,32,hw,BTNGOTO,i,0),WM_SETFONT,f,1 CheckDlgButton hw,CHECKAA,1
Dim As HMENU Menu=CreateMenu,MenuFile=CreateMenu AppendMenu Menu,MF_POPUP,MenuFile,"Файл" AppendMenu MenuFile,0,MENUNEW,@!"Создать\tCtrl+N" AppendMenu MenuFile,0,MENUOPEN,@!"Открыть\tCtrl+O" AppendMenu MenuFile,0,MENUSAVE,@!"Сохранить\tCtrl+S" AppendMenu MenuFile,0,MENUSAVEAS,@"Сохранить как.." AppendMenu MenuFile,MF_SEPARATOR,0,0 AppendMenu MenuFile,0,MENUEXIT,@!"Выход\tAlt+F4" SetMenu hw,Menu
Static As Const ACCEL Acl(6)={_ (FVIRTKEY Or FCONTROL,Asc("N"),MENUNEW),_ (FVIRTKEY Or FCONTROL,Asc("O"),MENUOPEN),_ (FVIRTKEY Or FCONTROL,Asc("S"),MENUSAVE),_ (FVIRTKEY Or FALT,VK_F4,MENUEXIT),_ (FVIRTKEY,VK_F3,BTNR),_ (FVIRTKEY Or FCONTROL,VK_F3,BTNL),_ (FVIRTKEY,VK_F5,BTNFIND)}
Var Atbl=CreateAcceleratorTable(Cast(LPACCEL,@Acl(0)),7)
Dim As zString Ptr p=PathGetArgs(GetCommandLine),p1=Any Dim As Long c=Peek(p) If c Then If c=34 Then p+=1 Else c=32 p1=StrChr(p,c):If p1 Then Poke p1,0 FileLoadSave p,0 EndIf
While GetMessage(@msg,0,0,0) If TranslateAccelerator(hw,Atbl,@msg)=0 Then Select Case msg.message Case WM_KEYDOWN Select Case msg.wParam Case 13 If msg.hwnd=tf Then Find BTNFIND End Select End Select TranslateMessage @msg DispatchMessage @msg EndIf Wend
DestroyAcceleratorTable Atbl DestroyMenu MenuFile DestroyMenu Menu ExitProcess 0 End Sub
Destructor zMem free End Destructor
Sub zMem.Free If m Then If HeapFree(GetProcessHeap,0,m)<>0 Then m=0:ln=0 EndIf End Sub
Function zMem.Start(b As Long)As ZString Ptr Dim As zString*255 s=Any If ln<=b Then free m=HeapAlloc(GetProcessHeap,0,b+5002) If m Then ln=b+5000:Poke m,0 Else StrFormatByteSize b,_ @s+wsprintf(s,!"Не удалось выделить память.\rЗапрошено "),50:MessageBox hw,s,0,16 EndIf txtln=0 Function=m End Function
Function zMem.GetTxt(h As HWND)As ZString Ptr Dim As Long x=TbLen(h) Dim As zString Ptr p=Start(x) If p Then txtln=SendMessage(h,WM_GETTEXT,x+2,p):Poke word,p+txtln,0:Function=p End Function
Sub Status Dim As zString*300 s=Any Dim As Long L1=Any,L2=Any,v=Any,ds,de SendMessage t,EM_GETSEL,@Ds,@De:v=De-Ds l1=SendMessage(t,EM_LINEFROMCHAR,ds,0) De=SendMessage(t,EM_LINEINDEX,L1,0) StrFormatByteSize TbLen(t),@s+wsprintf(s,IIf(v,_ @"Cтр. %d Поз. %d\%d Выделено %d Всего: ",_ @"Cтр. %d Поз. %d\%d Всего: "),l1+1,Ds-De+1,Ds+1,v),50 SetWindowText l,s End Sub
Function EditProc(h As HWND,msg As Ulong,wparam As WPARAM,lParam As LPARAM)As Long Function=callWindowProc(EProc,h,Msg,wParam,lParam) Select Case msg Case WM_MOUSEMOVE:If wParam=MK_LBUTTON Then Status Case WM_KEYDOWN:If wparam>32 And wparam<41 Then Status Case WM_LBUTTONDOWN,WM_RBUTTONDOWN:Status End Select End Function
Sub Find(mode As Long) Dim As zString*300 s=Any,s1=Any,s2=Any Dim As zString Ptr p=Any,p1=Any,p2=Any,m=Any,m2=Any,r=Any,w=TxtF.GetTxt(tf),rev Dim As Long c=Any,cnt=Any,Aa=Any,Ww=Any,wLen=TxtF.txtln,ds,de
If wLen=0 Then MessageBox hw,"Пустой поисковый запрос!","",48:Exit Sub Else m=Txt.GetTxt(t):p1=m Aa=IsDlgButtonChecked(hw,CHECKAA) Ww=IsDlgButtonChecked(hw,CHECKWW) SendMessage t,EM_GETSEL,@ds,@de
Select Case mode Case BTNR p1+=de Case BTNL rev=p1+ds Case BTNCNT cnt=0 Do:p=MegaInstr(p1,w,Aa,Ww,0) If p=0 Then Poke dword,w+250,3026478 wsprintf s,!"Найдено %d \"%s\"",cnt,w MessageBox hw,s,"",64:Status:Exit Sub EndIf If cnt=0 Then TbSetSel(t,p-m,p-m+wLen):TbScroll(t) cnt+=1:p1=p+wLen Loop
Case BUTTONREPLACE cnt=0 Do:p=MegaInstrAsm(p1,w,Aa,Ww,0)'первый проход, узнать количество замен If p=0 Then Exit Do cnt+=1:p1=p+wLen Loop
If cnt Then r=TxtR.GetTxt(tr) 'вычисление необходимой длины и инициация буфера m2=TxtBuff.Start(Txt.Txtln-(wLen*cnt)+(TxtR.txtln*cnt))
'Вызов функции замены cnt=MegaReplaceAsm(m,m2,w,r,Aa,Ww)
SendMessage t,EM_SETSEL,0,-1:TbAdd(t,m2)'выделить всё и вставить, чтоб состояние отмены сохранилось TxtBuff.free EndIf 'показ результата StrFormatByteSize Txt.Txtln,s1,30 c=TbLen(t) StrFormatByteSize c,s2,30:c-=Txt.Txtln StrFormatByteSize Abs(c),_ @s+wsprintf(s,!"Количество замен: %d\rРазмер текста до: %s\rНовый размер: %s\rРазница: %s",_ cnt,s1,s2,IIf(c<0,@"-",IIf(c,@"+",@""))),30 Status:MessageBox hw,s,"",64:Exit Sub End Select EndIf
p=MegaInstr(p1,w,Aa,Ww,rev) If p Then TbSetSel(t,p-m,p-m+wLen):TbScroll(t):Status:Exit Sub
MessageBox hw,"Не найдено",IIf(mode=BTNFIND,@"Произведён поиск в всём тексте",_ IIf(mode=BTNL,@!"От начала выделения до начала текста",@!"От конца выделения до конца текста")),64 End Sub
Sub FileLoadSave(s As ZString Ptr,mode As Long) Dim As zString*500 sh=Any Dim As ZString Ptr m=Any,msg=Any Dim As Long fSav=Any,ln=Any,b
If mode=0 Then'open msg=@"Загружено ":fSav=3 Else msg=@"Coxранено ":fSav=2 EndIf
Var f=CreateFile(s,-1073741824,3,0,fSav,128,0) If f<>-1 Then If mode=0 Then ln=GetFileSize(f,0) m=Txt.Start(ln) ReadFile f,m,ln,@b,0:Poke word,m+ln,0 SetWindowText t,m Else m=Txt.GetTxt(t) ln=Txt.txtln WriteFile f,m,ln,@b,0 EndIf CloseHandle f SendMessage t,EM_EMPTYUNDOBUFFER,0,0 If s<>@sFile Then lstrcpy sFile,s wsprintf sh,"Редактор - %s",PathFindFileName(s) SetWindowText hw,sh EndIf StrFormatByteSize b,@sh+wsprintf(sh,msg),50 SetWindowText l,sh End Sub
Function OpenSaveDialog(s As ZString Ptr,mode As Long)As Long Dim As OPENFILENAME ofn ofn.lStructSize=sizeof(ofn) ofn.lpstrFilter=@!"Все файлы(*.*)\0*.*\0Текстовые форматы\0"_ "*.txt;*.reg;*.rc;*.bas;*.bi;*.c;*.cpp;*.h;*.hpp;*.cmd;*.bat;*.ini;*.asm;*.inc;*.def;*.nfo\0\0" ofn.hwndOwner=hw ofn.nFilterIndex=2 ofn.lpstrFile=s ofn.lpstrInitialDir=ofn.lpstrFile ofn.nMaxFile=250 If mode=0 Then ofn.Flags=2627588:Return GetOpenFileName(@ofn) Else ofn.Flags=2686982:Return GetSaveFileName(@ofn) EndIf End Function
Function SaveMsg As Long Dim As zString*300 s=Any wsprintf s,!"Текст%s%s был изменён.\r\nСохранить изменения?",IIf(sFile[0],@" в файле ",@""),sFile Return MessageBox(hw,s,"Редактор",51) End Function
Function SaveFunction As Long Dim As zString*300 s=Any If SendMessage(t,EM_CANUNDO,0,0)Then Select Case SaveMsg Case 6'yes If sFile[0]Then FileLoadSave sFile,1 Else lstrcpy s,"Новый файл.txt" If OpenSaveDialog(s,1)=0 Then Exit Function FileLoadSave s,1 EndIf Case Is<>7:Exit Function End Select EndIf Return 1 End Function
Function WndProc(hWin As HWND,uMsg As UINT,wParam As WPARAM,lParam As LPARAM)As Long Dim As zString*300 s=Any Dim As Long x=Any,y=Any,ds=Any,de=Any,id=Any Select case uMsg Case WM_COMMAND Select Case HiWord(wParam) Case 0,1 id=LoWord(wParam) Select Case id Case 2000 To 2006 Find id
Case MENUNEW If SaveFunction Then sFile[0]=0:SetWindowText t,"" SendMessage t,EM_EMPTYUNDOBUFFER,0,0 SetWindowText hw,"Редактор - Новый файл.txt" EndIf
Case MENUOPEN If SaveFunction Then s[0]=0:If OpenSaveDialog(s,0)Then FileLoadSave s,0 EndIf
Case MENUSAVE If sFile[0]Then FileLoadSave sFile,1 Else SavNew:lstrcpy s,"Новый файл.txt" Sav:If OpenSaveDialog(s,1)=0 Then Exit Function FileLoadSave s,1 EndIf
Case MENUSAVEAS If sFile[0]=0 Then GoTo SavNew lstrcpy s,sFile:GoTo Sav
Case MENUEXIT If SaveFunction Then DestroyWindow hWin
Case BTNGOTO y=SendMessage(t,EM_GETLINECOUNT,0,0):x=GetDlgItemInt(hw,EDITGOTO,0,0) ds=SendMessage(t,EM_LINEINDEX,x-1,0) If ds=-1 Then x=y:ds=SendMessage(t,EM_LINEINDEX,x-1,0) de=ds+SendMessage(t,EM_LINELENGTH,ds,0) TbSetSel(t,ds,de):TbScroll(t) wsprintf s,"Строка: %d Число строк: %d",x,y SetWindowText l,s End Select
Case EN_CHANGE If wParam=EDIT+(EN_CHANGE Shl 16)Then Status
End Select
Case WM_DROPFILES DragQueryFile wParam,0,@s,255:DragFinish wParam If SaveFunction Then FileLoadSave s,0
Case WM_SIZE x=LoWord(lparam):y=HiWord(lparam) MoveWindow t,0,47,x,y-70,1 MoveWindow l,4,y-20,x,25,1
Case WM_CLOSE:If SaveFunction Then DestroyWindow hWin Case WM_DESTROY:PostQuitMessage 0 Case Else Return DefWindowProc(hWin,uMsg,wParam,lParam) End Select End Function Бат для компиляции.
Код @echo off :: Расположение папки компилятора. Задать и сохранить bat. Перетащить bas на этот bat. SET FBPATH=C:\FreeBASIC-1.05.0-win32 %~d1 cd %~p1 SET File=%~n1 SET LIBS=-lkernel32 -luser32 -lgdi32 -lshell32 -lComdlg32 -lshlwapi -lcomctl32.dll -lmsvcrt
If Not Exist %File%.rc GoTo norc echo compiling resource.. SET RES="%File%.res.obj" %FBPATH%\bin\win32\gorc /ni /nw /o /fo %RES% "%File%.rc" :norc echo compiling.. %FBPATH%\fbc.exe -w 3 %1 -r -lib If ErrorLevel 1 echo # Compile error! # && GoTo exit echo assembling.. %FBPATH%\bin\win32\as.exe --32 --strip-local-absolute %File%.asm -o %File%.o If ErrorLevel 1 echo # Asm error! # && GoTo exit echo linking.. %FBPATH%\bin\win32\ld.exe -e _main -subsystem windows "%FBPATH%\lib\win32\fbextra.x" -s --stack 102400,102400 -L %FBPATH%\lib\win32 -L "./" "%File%.o" %RES% -o "%File%.exe" -( %LIBS% -) If ErrorLevel 1 echo # Link error! # && GoTo exit if exist "%File%.o" del "%File%.o" if exist "%File%.res.obj" del "%File%.res.obj" echo # No errors ! # :exit pause ...
Обновлено - мелкие правки, и главное - устранение слетевшего переноса строк в кодах. (дело видимо в движке bb форума)
Сообщение отредактировал Somerick - Суббота, 27.08.2016, 17:24 |
|
| |