Quantcast
Channel: VBForums - CodeBank - Visual Basic 6 and earlier
Viewing all 1304 articles
Browse latest View live

VB6 - Multiline Textbox Printer

0
0
I had previously used a RichTextBox and the SelPrint routine, but I discovered that routine would not work with an InkEdit Control. With the help of jpbro, we put together a routine for the InkEdit Control (located in the parent forum). But that routine does not work with a Textbox, and I could not find anything online to fit the bill. So I came up with the routine attached.

This routine has experienced very little testing because my development computer does not currently have access to an actual printer. Bug reports would be appreciated.

J.A. Coutts
Attached Files

VB6 - Text Editor

0
0
I found a need for addtional functions that NotePad did not provide, so I came up with my own Text Editor. It has most of the functions of NotePad with a couple of extra ones.
Code:

File                Edit                Format                Search
-New                -Undo                -Word Wrap        -Find
-Open                -Cut                -Sort                -Find Next
-Save                -Copy                -Font
-Save as        -Paste
-Print                -Delete
-Exit                -Replace
                -Select All

The noticeable extra is the Sort function, which is covered in a previous post. The other extra is the ability to replace character ranges per line in addition to search and replace specific text. This is accomplished by replacing the double characters CrLf with a single character Cr, using a Split function to separate individual lines into a string array, looping through each line to replace the selected character range, and reassembling the complete string with the Join function. For large text files, search and Replace All by text will be slow, whereas Replace All by character count will be fast by comparison.

The print function has taken some time to put together, as printing from a Text Box is not straight forward, and it has experienced limited testing due to lack of an available printer. It also has been covered in a previous post.

The Line/Col function that comes with Text Editor is not considered an option, as in NotePad. Unlike NotePad, it is available in either Wrap or Unwrap modes, and is only activated by mouse click. If it is important to you, you are welcome to add activation by cursor keys.

Originally I used the API to perform the Edit functions since the VB functions were limited to 64K. But then I discovered that the keyboard functions are not limited to 64K, and perform most of those tasks quite well and with good speed. So it made a lot of sense to use the keyboard functions instead.

Like NotePad, Text Editor provides an adjustable window that remembers it's location and size.

The surprising part of this effort is that with the additional functionality provided, the executable is 1/3 the size of Notepad. I have added functions that meet my current needs, and other users may have specific functions that can be added to meet their needs.

J.A. Coutts
Attached Images
  
Attached Files

Fast Call COM object (activex.dll) ,Run Windows API

0
0
How to test the method of the COM object (activex.dll) in real time and run the windows api?
【Organizing, testing the project, and uploading examples after completion】

Method 1: Use VBS to create new objects or call the API library to call the WINDOWS function library
Method 2: Use VB6's Add-in plug-in method to dynamically create a project, create an object variable, and run
Method 3: The createobject ("excel.application") method creates a new Excel vba module, automatically adds code, and runs

It would be nice if each file could have a manual like PHP online tutorial.
Each process method and function can be directly tested without running into EXE.
Each method and function are listed in the manual, and you can run the test with one click to see the effect.

It's like there are tens of thousands of windows api, such as findwindow, messageboxa.
Make a table, write a description of the parameter types required by each API, add some test data, and you can run it directly to see the effect.
To achieve the same EXCEL formula, run windows api, Activex.Class1.Method (parameter 1, parameter 2) as a formula and run it immediately.

PHP Tutorial | Rookie Tutorial
https://www.runoob.com/php/php-tutorial.html
Rookie Tutorial Online Editor
https://www.runoob.com/try/runcode.p...intro&type=php
----------------
<! DOCTYPE html>
<html>
<body>

<? php
echo "Hello World!";
?>

</ body>
</ html>

There is a button "click to run code" on the page
-------------

Vb6 OpenOffice sdk(com.sun.star.ServiceManager)

0
0
need install jdk first

OpenOffice_sdk http://www.openoffice.org/api/basic/...l/tutorial.pdf
JDK1.8
32bit jdk https://www.7down.com/soft/267473.html
OpenOffice4.1.7 https://www.openoffice.org/download/

HKEY_CLASSES_ROOT\com.sun.star.ServiceManager
CLSID:{82154420-0FBF-11d4-8313-005004526AB4}
C:\Program Files (x86)\OpenOffice 4\program\soffice.exe -nodefault -nologo

Code:

Option Explicit

Private Sub Command1_Click()
NewExcelWord
'good_新建一个Excel和Word文档
End Sub

Private Sub Command3_Click()
'新建Excel类表格
'NewExcel
Dim mNoArgs()
Dim oSpreadsheetDocument As Object
Dim oTextDocument As Object
'Using StarOffice API - Basics 19
Dim oSM As Object
Set oSM = CreateObject("com.sun.star.ServiceManager")
Dim oDesktop
Set oDesktop = oSM.CreateInstance("com.sun.star.frame.Desktop")
'oDesktop = createUnoService("com.sun.star.frame.Desktop")
Dim sUrl
sUrl = "private:factory/scalc"
Set oSpreadsheetDocument = _
oDesktop.loadComponentFromURL(sUrl, "_blank", 0, mNoArgs())
 

 'GetCell = oSheet.getCellByPosition(nColumn, nRow)
 Dim oSheet As Object
 Set oSheet = oSpreadsheetDocument.getSheets().getByIndex(0)
 Dim Row As Long, Col As Long
 Row = 2
 Col = 2
 
  Dim s As String
 For Row = 1 To 3
 For Col = 1 To 5
 
 'oSheet.getCellByPosition(Col - 1, Row - 1).Value = Row & Col
 s = "v" & Row & Col
 
 'oSheet.getCellByPosition(Col - 1, Row - 1).v = Row & Col' long,value
 oSheet.getCellByPosition(Col - 1, Row - 1).String = s '
 Next
 Next

End Sub

Sub NewExcelWord()
Dim mNoArgs()
Dim oSpreadsheetDocument As Object
Dim oTextDocument As Object
'Using StarOffice API - Basics 19
Dim oSM As Object
Set oSM = CreateObject("com.sun.star.ServiceManager")
Dim oDesktop
Set oDesktop = oSM.CreateInstance("com.sun.star.frame.Desktop")
'oDesktop = createUnoService("com.sun.star.frame.Desktop")
Dim sUrl
sUrl = "private:factory/scalc"
Set oSpreadsheetDocument = _
oDesktop.loadComponentFromURL(sUrl, "_blank", 0, mNoArgs())
sUrl = "private:factory/swriter"
Set oTextDocument = _
oDesktop.loadComponentFromURL(sUrl, "_blank", 0, mNoArgs)
End Sub

Private Sub Command4_Click()
 'OpenWord
 '打开一个WORD文件
Dim mFileProperties(0) ' As New com.sun.star.beans.PropertyValue
Dim sUrl As String
Dim oSM As Object
Set oSM = CreateObject("com.sun.star.ServiceManager")
Dim oDesktop
Dim oDocument
Set oDesktop = oSM.CreateInstance("com.sun.star.frame.Desktop")

sUrl = "file:///" & App.Path & "\002word.doc"
sUrl = Replace(sUrl, "\", "/")
sUrl = GetFileName(App.Path & "\002word.doc")

'mFileProperties(0).Name = "FilterName"
'mFileProperties(0).Value = "scalc: Text - txt - csv (StarCalc)"
Set oDocument = oDesktop.loadComponentFromURL(sUrl, "_blank", 0, mFileProperties())
End Sub
Function GetFileName(ByVal sUrl As String) As String
sUrl = "file:///" & sUrl
sUrl = Replace(sUrl, "\", "/")
GetFileName = sUrl
End Function

Private Sub Command5_Click()
 'Open Excel File
 '打开一个Excel文件,GOOD
Dim mFileProperties(0) ' As New com.sun.star.beans.PropertyValue
Dim sUrl As String
Dim oSM As Object
Set oSM = CreateObject("com.sun.star.ServiceManager")
Dim oDesktop
Dim oDocument
Set oDesktop = oSM.CreateInstance("com.sun.star.frame.Desktop")

sUrl = GetFileName(App.Path & "\001excel.xls")

Set oDocument = oDesktop.loadComponentFromURL(sUrl, "_blank", 0, mFileProperties())
End Sub

vb Fast Crc32 (crc32str,Crc32File)

0
0
Running speed test record: average time,Evaluation object
====================
use CbsPersist_20200521111942.log(161m),not 7z format

time(ms) TestObject
125.76 Crc32_Wqweto
281.03 Crc32ByAsm
326.17 Crc32Api
458.95 Crc32_LaVolpe
461.22 Crc32FromByte
====================
(USE 320M File,7z format)

----------------Advanced optimization:
249.41 Crc32_Wqweto
555.39 Crc32ByAsm
648.79 Crc32Api

905.41 Crc32_LaVolpe
906.42 Crc32FromByte
----------------Pentium Pro(Tm) optimization:
573.88 Crc32ByAsm UsedTime(Ms)
665.31 Crc32Api UsedTime(Ms)
737.25 Crc32FromByte UsedTime(Ms)
739.31 Crc32_LaVolpe UsedTime(Ms)
====================
Why is this forum picture compressed automatically? The total capacity of attachments uploaded at the same time is also pitiful?
Name:  FunctionSpeedTesting.jpg
Views: 109
Size:  47.6 KB
method1:use api RtlComputeCrc32
Code:

Private Declare Function RtlComputeCrc32 Lib "ntdll.dll" ( _
    ByVal dwInitial As Long, _
    ByVal pData As Long, _
    ByVal iLen As Long) As Long

Public Function Crc32Api ( tBuff() As Byte) as long   
    Crc32Api = RtlComputeCrc32(0, VarPtr(tBuff(0)), UBound(tBuff) + 1)
End Function

Public Function GetStringCRC32(ByVal InString As String) As String
'123456789=CBF43926
    Dim lRet As Long, tBuff() As Byte
   
    tBuff = StrConv(InString, vbFromUnicode)
   
    lRet = RtlComputeCrc32(0, VarPtr(tBuff(0)), UBound(tBuff) + 1)
    GetStringCRC32 = Hex(lRet)
End Function

method2:
Code:

'call InitCrc32 'First
Dim CRC32Table(255) As Long


Private Declare Function MultiByteToWideChar Lib "kernel32 " (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long) As Long
Private Declare Function WideCharToMultiByte Lib "kernel32 " (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, ByVal lpDefaultChar As Long, ByVal lpUsedDefaultChar As Long) As Long
Private Const CP_ACP = 0 ' default to ANSI code page
Private Const CP_UTF8 = 65001 ' default to UTF-8 code page

'string to UTF8
Public Function EncodeToBytes(ByVal sData As String) As Byte() ' Note: Len(sData) > 0
Dim aRetn() As Byte
Dim nSize As Long
nSize = WideCharToMultiByte(CP_UTF8, 0, StrPtr(sData), -1, 0, 0, 0, 0) - 1
If nSize = 0 Then Exit Function
ReDim aRetn(0 To nSize - 1) As Byte
WideCharToMultiByte CP_UTF8, 0, StrPtr(sData), -1, VarPtr(aRetn(0)), nSize, 0, 0
EncodeToBytes = aRetn
Erase aRetn
End Function

Function Crc32FromByte(B() As Byte) As Long
    Dim i As Long, iCRC As Long
    iCRC = &HFFFFFFFF
    For i = 0 To UBound(B)
        iCRC = (((iCRC And &HFFFFFF00) \ &H100) And &HFFFFFF) Xor CRC32Table((iCRC And &HFF) Xor B(i))
    Next
    Crc32FromByte = iCRC Xor &HFFFFFFFF
End Function

Function crc32byte(B() As Byte) As long
    Dim i As Long, iCRC As Long, lngA As Long, ret As Long
    dim bytT As Byte, bytC As Byte
   
    iCRC = &HFFFFFFFF
    For i = 0 To UBound(B)
        bytC = B(i)
        bytT = (iCRC And &HFF) Xor bytC
        lngA = ((iCRC And &HFFFFFF00) \ &H100) And &HFFFFFF
        iCRC = lngA Xor CRC32Table(bytT)
    Next
    ret = iCRC Xor &HFFFFFFFF
    crc32byte =ret
End Function

'string's CRC32
Public Function crc32str(item As String) As String
    Dim i As Long, iCRC As Long, lngA As Long, ret As Long
    Dim B() As Byte, bytT As Byte, bytC As Byte
    B = StrConv(item, vbFromUnicode)
   
    iCRC = &HFFFFFFFF
    For i = 0 To UBound(B)
        bytC = B(i)
        bytT = (iCRC And &HFF) Xor bytC
        lngA = ((iCRC And &HFFFFFF00) \ &H100) And &HFFFFFF
        iCRC = lngA Xor CRC32Table(bytT)
    Next
    ret = iCRC Xor &HFFFFFFFF
    crc32str = Right("00000000" & Hex(ret), 8)
End Function

Public Function Crc32File(sFilePath As String, Optional Block As Long = 1024) As Long ' String
'改进后180M左右以上的文件更快了,超过“GetFileCRC32_MapFile”
    Dim hFile As Long, i As Long, iCRC As Long, lngA As Long, Size As Long, ret As Long
    Dim bytT As Byte, bytC As Byte
    Dim sSize As Currency, total As Currency, Ub As Long
    total = FileLen(sFilePath)
    If total = 0 Then Exit Function 'Len(Dir(sFilePath))
    If total < 0 Then total = total + 256 ^ 4
    sSize = Block * 1024
    hFile = FreeFile
    Open sFilePath For Binary Access Read As #hFile
    iCRC = &HFFFFFFFF
'    Dim sSize2 As Long
'    sSize2 = sSize + 1
    'Dim sSizeX As Long
    'sSizeX = sSize - 1

    Ub = sSize - 1
    ReDim B(Ub) As Byte
 
'sSize=8,sSizeX=7
    While total >= sSize '>=8  '722-725
    'While total > sSizeX  '>7
    'While total > sSize - 1 '慢去 '713-715
        Get #hFile, , B
        For i = 0 To Ub
            bytC = B(i)
            bytT = (iCRC And &HFF) Xor bytC
            lngA = ((iCRC And &HFFFFFF00) \ &H100) And &HFFFFFF
            iCRC = lngA Xor CRC32Table(bytT)
        Next
        total = total - sSize
    Wend
   
    If total > 0 Then '余下区块
        Ub = total - 1
        ReDim B(Ub) As Byte
        Get #hFile, , B
        For i = 0 To Ub
            bytC = B(i)
            bytT = (iCRC And &HFF) Xor bytC
            lngA = ((iCRC And &HFFFFFF00) \ &H100) And &HFFFFFF
            iCRC = lngA Xor CRC32Table(bytT)
        Next
    End If
   
 
   
    Close #hFile
    ret = iCRC Xor &HFFFFFFFF
    Crc32File = ret
    'Crc32File = Right("00000000" & Hex(ret), 8)
End Function
'CRC32 Table
Public Function InitCrc32(Optional ByVal Seed As Long = &HEDB88320, Optional ByVal Precondition As Long = &HFFFFFFFF) As Long
    Dim i As Integer, j As Integer, CRC32 As Long, Temp As Long
    For i = 0 To 255
        CRC32 = i
        For j = 0 To 7
            Temp = ((CRC32 And &HFFFFFFFE) \ &H2) And &H7FFFFFFF
            If (CRC32 And &H1) Then CRC32 = Temp Xor Seed Else CRC32 = Temp
        Next
        CRC32Table(i) = CRC32
    Next
    InitCrc32 = Precondition
End Function

METHOD3: GetCrcByASM.CLS
Code:

Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Private Declare Sub CpyMem4 Lib "msvbvm60.dll" Alias "GetMem4" (Source As Any, Destination As Any)

Dim ASMBL() As Byte
Dim Table(0 To 255) As Long
Function Crc32ByAsm(Data() As Byte) As Long
'0为下标的数组,原来函数名:ChecksumDataEx
    Dim CRC32 As Long
    CRC32 = &HFFFFFFFF
    On Local Error GoTo ErrCB
    CallWindowProc VarPtr(ASMBL(0)), VarPtr(CRC32), VarPtr(Data(0)), VarPtr(Table(0)), UBound(Data) + 1
ErrCB:
    Crc32ByAsm = Not CRC32
End Function

Function ChecksumFileEx(Path As String) As Long
On Error GoTo ErrFC
Dim FreeF As Integer, Data() As Byte
FreeF = FreeFile
Open Path For Binary Access Read As #FreeF
ReDim Data(0 To LOF(FreeF) - 1) As Byte
Get #FreeF, , Data
Close #FreeF
ChecksumFileEx = Crc32ByAsm(Data)
ErrFC:
End Function
Function ChecksumFile(Path As String) As String
ChecksumFile = Hex(ChecksumFileEx(Path))
End Function

Function ChecksumTextEx(Text As String) As Long
If Len(Text) = 0 Then Exit Function
ChecksumTextEx = Crc32ByAsm(StrConv(Text, vbFromUnicode))
End Function
Function ChecksumText(Text As String) As String
ChecksumText = Hex(ChecksumTextEx(Text))
End Function


Function Crc32ByAsm2(Data() As Byte) As Long '非0下标
Dim CRC32 As Long
CRC32 = &HFFFFFFFF 'CRC32 初始值(必须)
On Local Error GoTo ErrCB
Dim DLen As Long
DLen = UBound(Data) - LBound(Data) + 1
CallWindowProc VarPtr(ASMBL(0)), VarPtr(CRC32), VarPtr(Data(LBound(Data))), VarPtr(Table(0)), DLen
ErrCB:
Crc32ByAsm2 = Not CRC32
End Function

Function ChecksumData(Data() As Byte) As String
ChecksumData = Hex(Crc32ByAsm(Data))
End Function

Function LngToBin(ipLong As Long) As Byte()
Dim tB() As Byte
ReDim tB(1 To 4)
CpyMem4 ipLong, tB(1)
LngToBin = tB
End Function
Function BinToLng(ipBin4() As Byte) As Long
CpyMem4 ipBin4(LBound(ipBin4)), BinToLng
End Function

Sub IntAsm()
Dim i As Long, j As Long

Const ASM As String = "5589E557565053518B45088B008B750C8B7D108B4D1431DB8A1E30C3C1E80833049F464975F28B4D088901595B585E5F89EC5DC21000"

' Decoded ASM source from HIEW 6.86 (Hacker's View)
'
' 55 PUSH BP
' 89E5 MOV BP,SP
' 57 PUSH DI
' 56 PUSH SI
' 50 PUSH AX
' 53 PUSH BX
' 51 PUSH CX
' 8B4508 MOV AX,DI[08]
' 8B00 MOV AX,BX[SI]
' 8B750C MOV SI,DI[0C]
' 8B7D10 MOV DI,DI[10]
' 8B4D14 MOV CX,DI[14]
' 31DB XOR BX,BX
' 8A1E30C3 MOV BL,0C330
' C1E808 SHR AX,008 <-.
' 3304 XOR AX,[SI] |
' 9F LAHF |
' 46 INC SI |
' 49 DEC CX |
' 75F2 JNE 000000018 -'
' 8B4D08 MOV CX,DI[08]
' 8901 MOV BX[DI],AX
' 59 POP CX
' 5B POP BX
' 58 POP AX
' 5E POP SI
' 5F POP DI
' 89EC MOV SP,BP
' 5D POP BP
' C21000 RETN 00010

ReDim ASMBL(0 To 53) 'Len(ASM) \ 2 - 1
For i = 1 To Len(ASM) - 1 Step 2
ASMBL(j) = Val("&H" & Mid(ASM, i, 2))
j = j + 1
Next i

Dim vCRC32 As Long, vB As Boolean
Const vXor32 As Long = &HEDB88320
For i = 0 To 255
vCRC32 = i
For j = 8 To 1 Step -1
vB = vCRC32 And 1
vCRC32 = ((vCRC32 And &HFFFFFFFE) \ 2&) And &H7FFFFFFF
If vB Then vCRC32 = vCRC32 Xor vXor32
Next j
Table(i) = vCRC32
Next i
End Sub
Private Sub Class_Initialize()
IntAsm
End Sub

method 4:
Code:

Function Crc32_LaVolpe(Buffer() As Byte) As Long
Dim crc32val As Long, i As Long
crc32val = &HFFFFFFFF
For i = 0 To UBound(Buffer)
crc32val = (((crc32val And &HFFFFFF00) \ &H100&) And &HFFFFFF) Xor CRC32Table((crc32val And &HFF) Xor Buffer(i))
Next i
Crc32_LaVolpe = crc32val Xor &HFFFFFFFF
End Function

Attached Images
 

Friend in Class1-VB6 calls multiple methods to run speed test

0
0
Optimized for vb6 running speed
call function Fastest c=Bas_Sum(a,b)
call Friend is quick than "public function",The operating speed is 4.6 times faster
-----------
Class_OBJ 452.38 (dim a as class1 ,call a.Sum(**))
Class_Friend_Ptr 70.38
Class_Friend 80.65(call a.FrinedSum)
----------
call objptr like stdcall :cUniversalDLLCalls.CallFunction_COM(***),The operating speed is 1 times faster(up 100%)

Pointer call function address of COM object:
call com dll(activex.dll).FrinedSum(***), Speed increased by 5.6 times
(465.77 pk 70.57)
It takes 827 seconds to call activex.exe, which is 14000 times more than the time to directly call the process

Unfortunately, this seems to be no way. It is like operating the "EXCEL.APPLICATION" object in VB6 and controlling the third-party process of excel.exe. It is very slow. Unless running in EXCEL VBA, it is also about 4 times slower than VB6, but it is slower than ActiveX.EXE with 14,000 times is still much better.
This is just a theoretical number and has not been tested specifically, but calling activex.exe is really slow.
=====================
method1:Friend Function FrinedSum(ByRef a As Long, ByRef b As Long) As Long
method2:Public Function Sum(ByRef a As Long, ByRef b As Long) As Long
method3:Public Function Bas_Sum in moudle.bas
method4:Public Sub BasSub_Sum in moudle.bas

com dll=(class1.cls in comdll1.dll)
actexe=(class1.cls in activex1.exe)
class1.cls in same vb project
call function sum(a,b)
call sub sum(a,b,returnvalue)
The main methods of testing

Code:

TestCount = 1000000*20
Sub Test_Exe1_MySum_object(id As Long)
dim Exe1 as new activex1_exe.Class1
Dim i As Long
For i = 1 To TestCount
    a1 = 3
    b1 = 4
    'Call Exe1_MySum2(ThisExe1, a1, b1, Ret) 'by objptr stdcall
    Ret = Exe1.Sum(a1, b1)
next
end sub

Public Function Bas_Sum(ByRef a As Long, ByRef b As Long) As Long 'method3
 
Bas_Sum = a + b
a = a * a
b = b * b
End Function
Public Sub BasSub_Sum(ByRef a As Long, ByRef b As Long, ByRef Value1 As Long) 'method4
 
Value1 = a + b
a = a * a
b = b * b
End Sub

class1.cls
Code:

Option Explicit
 Public Event Sum2(ByRef id As Long)   

Public Sub Test()
MsgBox "ComDll.lib-test"
End Sub
Public Sub TEST2()
MsgBox "ComDll.lib-test2"
End Sub
Public Function Sum(ByRef a As Long, ByRef b As Long) As Long
 
Sum = a + b
a = a * a
b = b * b
End Function
 
Public Sub test3()
Dim i As Long
Dim v2 As Long
Dim V1 As Long
For i = 1 To 1
V1 = i
v2 = i
 
RaiseEvent Sum2(v2)
 
Next
End Sub
Friend Function FrinedSum(ByRef a As Long, ByRef b As Long) As Long
 
MsgBox "FrinedSum"
FrinedSum = a + b
a = a * a
b = b * b
End Function
Friend Function FrinedSum2(ByRef a As Long, ByRef b As Long) As Long
 
MsgBox "Class_FrinedSum2"
FrinedSum2 = a + b
a = a * a
b = b * b
End Function

Alt+NumPad input for Unicode TextBox with surrogate pair support

0
0
When using Alt+NumPad for Unicode input I get a bogus character in Notepad/Notepad++ and all other Unicode TextBox implementations that I tried. WordPad and InkEdit, on the other hand. works OK, including surrogate pairs.

Test summary:
Alt+128512 (&H1F600) WordPad/InkEdit , Notepad/Notepad++/TextBoxW/ucText Nothing
Alt+173569 (&H2A601) WordPad/InkEdit , Notepad/Notepad++TextBoxW/ucText ☺ (&H263A, 9786)
Alt+931 (&H03A3) WordPad/InkEdit Σ , Notepad/Notepad++/TextBoxW/ucText ú (&HFA, 250)

Here is sample code that overrides the internal Alt+NumPad behavior:
1. Assumes you have a subclassed Unicode TextBox with source code that exposes Translate Accelerator.
2, Make sure NumLock is On before testing.
3. Tested with Segoe UI Regular.

Code:

Option Explicit

Private mbDeleteChar As Boolean

Private Function KeyPressed(ByVal KeyCode As KeyCodeConstants) As Boolean
  KeyPressed = CBool((GetAsyncKeyState(KeyCode) And &H8000&) = &H8000&)
End Function

Private Function ToSurrogatePair(ByVal i As Long) As String
  Dim Hi              As Integer, Lo As Integer
  On Error GoTo ErrHandler
  i = i - &H10000
  Hi = i \ &H400 + &HD800
  Select Case Hi
    Case &HD800 To &HDBFF
      Lo = i Mod &H400 + &HDC00
      Select Case Lo
        Case &HDC00 To &HDFFF
          'Debug.Print Hex(Hi), Hex(Lo)
          ToSurrogatePair = ChrW$(Hi) & ChrW$(Lo)
      End Select
  End Select
ErrHandler:
End Function

'Build string in Translate Accelerator WM_SYSKEYDOWN.
Friend Function TranslateAccel(pMsg As Msg) As Boolean
  Static mSysWord  As String
 
    Case WM_SYSKEYDOWN
      If KeyPressed(vbKeyMenu) Then 'Alt Pressed
        Select Case pMsg.wParam
          Case vbKeyNumpad0 To vbKeyNumpad9
            mSysWord = mSysWord & ChrW$(pMsg.wParam - 48)
        End Select
      End If
    Case WM_CHAR
      If Len(mSysWord) Then
        Dim i                As Long
        Dim s                As String
        On Error Resume Next
        i = CLng(mSysWord)
        Select Case i
          Case &HD800& To &HDBFF& 'Skip Reserved
          Case Is <= &HFFFF& '0 - 65535
            s = ChrW$(i)
          Case Is <= &H10FFFF 'Unicode max value
            s = ToSurrogatePair(i)
        End Select
        If Len(s) Then
          SelText = s 'Insert as SelText
          mSysWord = vbNullString 'Reset
          mbDeleteChar = True 'To delete bogus WM_CHAR that Alt+ generated internally.
        End If
        On Error GoTo 0
      End If

'Finally delete the bogus character that appears in WM_CHAR when Alt is released.
myWndProc:
    Case WM_CHAR
      If mbDeleteChar Then
        mbDeleteChar = False
        wParam = 0
      End If

Similar code was tested in Krools TextBoxW (use wParam in lieu pf pMsg.wParam and KeyChar = 0 in WindowProcControl) and it appears to be working OK here. TextBoxW.Zip atttached.

TextBoxW.zip
Attached Files

Vmware Sdk For vb6(VixCOM64.dll),vbs-CreateObject("VixCOM.VixLib")

0
0
Need VMWare VIX Automation Tools and SDK

Code:

'Reference
'C:\Windows\SysWOW64\regsvr32.exe ***\VixCOM64.dll
'Reference VixCOM64.dll TO vb6 Project
Dim lib As VixCOM.VixLib
Dim vmPath As String

Private Sub Form_Load()
vmPath = "***/Windows 7.vmx"

' Copyright 2006 VMware, Inc.
' All rights not expressly granted to you by VMware, Inc. are reserved.
'

' VixCOM VBScript Sample Script (powerOn)
'
' This demonstrates how to open a VM, power it on and power it off.
'
' This uses the Wait function to block after starting each
' asynchronous function. This effectively makes the asynchronous
' functions synchronous, because Wait will not return until the
' asynchronous function has completed.
'
' Instructions for Windows 2000 and later operating systems:
'
'  - there should be an accompanying file named 'powerOn.wsf'
'    It is placed in the same directory as this file during
'    product installation. This file is responsible for setting
'    up the Windows Script Host environment and loading the
'    VixCOM type library, thereby enabling this script to
'    reference symbolic constants such as VIX_API_VERSION
'
'  - in a command line window, type:
'    cscript //nologo powerOn.wsf
'
Dim results
'Dim lib
Dim job
Dim host
Dim vm As IVM2
Dim err
Dim useWorkstation
Dim hostType
Dim hostName
Dim hostUsername
Dim hostPassword

Dim poweronOption

' Certain arguments differ when using VIX with VMware Server 2.0 and
' VMware Workstation.
'
' Comment out this line to use this code with VMware Server 2.0.
useWorkstation = 1

If useWorkstation Then
  hostType = VixCOM.Constants.VIX_SERVICEPROVIDER_VMWARE_WORKSTATION '=3
  hostName = Empty
  hostUsername = Empty
  hostPassword = Empty
  'vmPath = "***/Windows 7.vmx"
  poweronOption = VixCOM.Constants.VIX_VMPOWEROP_LAUNCH_GUI '=512
Else
  ' For VMware Server 2.0
  hostType = VixCOM.Constants.VIX_SERVICEPROVIDER_VMWARE_VI_SERVER
  hostName = "https://192.20.30.40:8333/sdk"
  hostUsername = "Administrator"
  hostPassword = "password"
  vmPath = "[standard] winxppro/winxppro.vmx"
  poweronOption = VixCOM.Constants.VIX_VMPOWEROP_NORMAL
End If

Set lib = CreateObject("VixCOM.VixLib")

' Connect to the local installation of Workstation. This also intializes the VIX API.
Set job = lib.Connect(VixCOM.Constants.VIX_API_VERSION, hostType, hostName, 0, hostUsername, hostPassword, 0, Nothing, Nothing)

' results needs to be initialized before it's used, even if it's just going to be overwritten.
Set results = Nothing

' Wait waits until the job started by an asynchronous function call has finished. It also
' can be used to get various properties from the job. The first argument is an array
' of VIX property IDs that specify the properties requested. When Wait returns, the
' second argument will be set to an array that holds the values for those properties,
' one for each ID requested.
err = job.Wait(Array(VixCOM.Constants.VIX_PROPERTY_JOB_RESULT_HANDLE), results)
If err <> 0 Then QuitIfError (err)

' The job result handle will be first element in the results array.
Set host = results(0)

' Open the virtual machine with the given .vmx file.
Set job = host.OpenVM(vmPath, Nothing)
err = job.Wait(Array(VixCOM.Constants.VIX_PROPERTY_JOB_RESULT_HANDLE), results)
If CLng(err) <> 0 Then QuitIfError (err)


Set vm = results(0)
'MsgBox TypeName(vm)


' Power on the virtual machine we just opened. This will launch Workstation if it hasn't
' already been started.
Set job = vm.PowerOn(poweronOption, Nothing, Nothing)
' WaitWithoutResults is just like Wait, except it does not get any properties.
err = job.WaitWithoutResults()
If CLng(err) <> 0 Then QuitIfError (err)
'MsgBox "正在启动,启动完成后,点确定按钮"
MsgBox "Doing Start Vmware virtual machine,When Start Successfull,CLICK OK BUTTON", vbOKOnly

' Here you would do any operations on the guest inside the virtual machine.

' Power off the virtual machine. This will cause Workstation to shut down if it
' was not running previous to the call to PowerOn.
'If MsgBox("是否关闭?", vbYesNo) = vbYes Then
If MsgBox("Do You Want to Close Vmware virtual machine?", vbYesNo) = vbYes Then
Set job = vm.PowerOff(VixCOM.Constants.VIX_VMPOWEROP_NORMAL, Nothing)
err = job.WaitWithoutResults()
If CLng(err) <> 0 Then QuitIfError (err)

host.Disconnect
End If
'MsgBox "测试完成"
MsgBox "TestOk"

End Sub
Sub QuitIfError(errID)
On Error GoTo DoErr
MsgBox "errID:" & CLng(errID)
'  If lib.ErrorIndicatesFailure(err) Then
'      WScript.Echo ("Error: " & lib.GetErrorText(err, Empty))
'      WScript.Quit
'  End If
Exit Sub
DoErr:
MsgBox err.Description
End Sub


VB6 radial Progress-Control

0
0
Just another one of these circular Progress-UCs, which recently seem "all the rage" ... ;)

What's different with this one?
- it's really small (only about 80 Lines of Code), so no need to put this into a compiled OCX
- it's entirely GDI-based (just for fun, I've tried to avoid anything "Cairo or GDIPlus")
- it uses a single ChangeSettings-MethodCall ...instead having to set (or implement) a bunch of behaviour-Properties

Here is, what it looks like:


And here's the Zip with the DemoCode:
ucRadialProgress.zip

Have fun,

Olaf
Attached Files

[vb6] Virtual Pet Roach v1.2 (Updated 08/06/20)

0
0
Since I see the famouse "sheep.exe" I wanted to create something like a virtual pet... finally 2 decades later I found the time to do it.
This is a cockroach that roam the screen. It run outside the screen when touched with the cursor and if computer is left idle for certain time, start spawning more cockroachs until certain limit.
Animation of every limb and movement is made with detail and looks very realistic.

Also this code can be usefull te see how to interact with the mouse, how to calculate angles, idle detection , creating a systray and draw 8 bits transparency forms (32bpp)

Name:  VirtPet_Snap1.jpg
Views: 169
Size:  15.2 KB
Running wild over desktop windows

Name:  VirtPet_Snap2.jpg
Views: 172
Size:  40.0 KB
Debug movement screen enabled

PD: Also got a cool about screen effect.


Download: prjVirtualPet_v1.2_Src.zip


v1.1 - Memory leak completely fixed!!!!
v1.2 - Fixed display on HighDPI screen

TODO: Multi monitor support
Attached Images
  
Attached Files

mBox Reader

0
0
Hi this is a mail message box reader I made to read old usenet message box files. if you want any mail box files you can find a load on wayback machine. with this little app it makes it easyer to read each message. anyway hope you like it.

Name:  logo.jpg
Views: 54
Size:  40.6 KB

Download Source Project:

mBox.zip
Attached Images
 
Attached Files

Text To Picture

0
0
Hi
This is a project I made sometime ago, it allows you to encrypt text and save as a bitmap, You can then load the bitmap and with the right encrypt key you used you can decrypt the text.
Hope you find it usfull.

Name:  logo.jpg
Views: 8
Size:  153.9 KB

Download Project
Text2Pic.zip
Attached Images
 
Attached Files

Random Password Generator

0
0
Hi,
This is a password generator I made a few months back with the help of a friend who added a few featires. it contains many options skins and more hope you like it.

Name:  logo.jpg
Views: 55
Size:  50.7 KB

Download Source Code:
PwsGenStd.zip
Attached Images
 
Attached Files

Radial Busy GIF

0
0
I was looking for a simple rotary graphic to indicate that a program was busy performing a task. I found such an image at this Web site:
http://www.ajaxload.info/
You can change the color combinations to produce and download the Animated GIF file. I have included 2 circular busy GIFs, one with a white background and one with a light yellow background.

Unfortunately, VB6 does not directly support animated GIF files. Based on an Animated GIF Control by Jen Sam Lam, I put together the attached User Control. An animated GIF is a layered structure consisting of a number of frames. Because none of the picture based controls in VB6 support the layered structure, it is broken up into the individual frames in an Image array. In this case there are 8 frames controlled by a timer.

The individual frames are converted into a temporary file and loaded to the image array. I was wondering if there was a more direct way of loading the individual frames. Feedback is welcome.

J.A. Coutts
Attached Images
 
Attached Files

ColorPicker similar to PhotoShop's (Learn vbRichClient5.Cairo drawing step by step)

0
0
There are several good ColorPickers in the CodeBank, for example:

(1) ColinE66's ColourPicker[vbRichClient]: http://www.vbforums.com/showthread.p...r-vbRichClient
(2) Eduardo's Wheel Color Picker: http://www.vbforums.com/showthread.p...l-Color-Picker

But I need a ColorPicker similar to PhotoShop's, because PhotoShop is the most widely used drawing tool in the world.

wqweto wrote a very good ColorPicker similar to PhotoShop's 18 years ago, but its UI is so old that I can't use it in my projects. So I decided to rewrite wqweto's ColorPicker with vbRichClient5.Cairo.

Although I've used RC5.Cairo in my Spread and CodeEditor, Cairo's syntax is completely different from VB6 GDI, so that as long as I don't use Cairo for 6 months, I'll completely forget Cairo's usage, and I need to start learning it from scratch. Therefore, I think it necessary to record the process of rewriting wqweto's ColorPicker with RC5.Cairo for others interested in learning Cairo drawing.

It will take some time to rewrite wqweto's ColorPicker, because I need to spend a lot of time to search for information and test the usage of Cairo. Fortunately, Olaf has left a large number of Cairo examples on this forum. Searching these examples can solve almost all Cairo drawing problems.

wqweto's real-time PhotoShop like color-picker
http://www.planet-source-code.com/vb...xtCodeId=36529

Note:
My ultimate goal is to use RC5.Cairo to develop a professional and modern ColorPicker similar to PhotoShop's, which will be named vbColorPicker. If I have more time in the future, I'll rewrite Eduardo's Wheel Color Picker with Cairo and add it to vbColorPicker to form vbColorPickerPro. As for cwColorPicker, I need Olaf's help and guidance to complete it. Maybe ColinE66 is a better candidate to develop it.

List of revisions:
Code:

2020-06-25 p.m.
- Draw border on a picture(DreamManor -- RC5.Cairo)
- Draw bar selector (DreamManor -- RC5.Cairo)
- Draw bar selector (Olaf -- Best Practice)
- Draw rect marker (DreamManor -- RC5.Cairo)

2020-06-25
- First released learning/rewriting framework

Attached Files

mBox Reader

0
0
Hi this is a mail message box reader I made to read old usenet message box files. if you want any mail box files you can find a load on wayback machine. with this little app it makes it easyer to read each message. anyway hope you like it.

Name:  logo.jpg
Views: 142
Size:  40.6 KB

Download Source Project:

mBox.zip
Attached Images
 
Attached Files

Text To Picture

0
0
Hi
This is a project I made sometime ago, it allows you to encrypt text and save as a bitmap, You can then load the bitmap and with the right encrypt key you used you can decrypt the text.
Hope you find it usfull.

Name:  logo.jpg
Views: 127
Size:  153.9 KB

Download Project
Text2Pic.zip
Attached Images
 
Attached Files

Random Password Generator

0
0
Hi,
This is a password generator I made a few months back with the help of a friend who added a few featires. it contains many options skins and more hope you like it.

Name:  logo.jpg
Views: 143
Size:  50.7 KB

Download Source Code:
PwsGenStd.zip
Attached Images
 
Attached Files

Radial Busy GIF

0
0
I was looking for a simple rotary graphic to indicate that a program was busy performing a task. I found such an image at this Web site:
http://www.ajaxload.info/
You can change the color combinations to produce and download the Animated GIF file. I have included 2 circular busy GIFs, one with a white background and one with a light yellow background.

Unfortunately, VB6 does not directly support animated GIF files. Based on an Animated GIF Control by Jen Sam Lam, I put together the attached User Control. An animated GIF is a layered structure consisting of a number of frames. Because none of the picture based controls in VB6 support the layered structure, it is broken up into the individual frames in an Image array. In this case there are 8 frames controlled by a timer.

The individual frames are converted into a temporary file and loaded to the image array. I was wondering if there was a more direct way of loading the individual frames. Feedback is welcome.

J.A. Coutts

Updated: 06/20/2020 - See later post for details
Attached Images
 
Attached Files

ColorPicker similar to PhotoShop's (Learn vbRichClient5.Cairo drawing step by step)

0
0
There are several good ColorPickers in the CodeBank, for example:

(1) ColinE66's ColourPicker[vbRichClient]: http://www.vbforums.com/showthread.p...r-vbRichClient
(2) Eduardo's Wheel Color Picker: http://www.vbforums.com/showthread.p...l-Color-Picker

But I need a ColorPicker similar to PhotoShop's, because PhotoShop is the most widely used drawing tool in the world.

wqweto wrote a very good ColorPicker similar to PhotoShop's 18 years ago, but its UI is so old that I can't use it in my projects. So I decided to rewrite wqweto's ColorPicker with vbRichClient5.Cairo.

Although I've used RC5.Cairo in my Spread and CodeEditor, Cairo's syntax is completely different from VB6 GDI, so that as long as I don't use Cairo for 6 months, I'll completely forget Cairo's usage, and I need to start learning it from scratch. Therefore, I think it necessary to record the process of rewriting wqweto's ColorPicker with RC5.Cairo for others interested in learning Cairo drawing.

It will take some time to rewrite wqweto's ColorPicker, because I need to spend a lot of time to search for information and test the usage of Cairo. Fortunately, Olaf has left a large number of Cairo examples on this forum. Searching these examples can solve almost all Cairo drawing problems.

wqweto's real-time PhotoShop like color-picker
http://www.planet-source-code.com/vb...xtCodeId=36529

Note:
My ultimate goal is to use RC5.Cairo to develop a professional and modern ColorPicker similar to PhotoShop's, which will be named vbColorPicker. If I have more time in the future, I'll rewrite Eduardo's Wheel Color Picker with Cairo and add it to vbColorPicker to form vbColorPickerPro. As for cwColorPicker, I need Olaf's help and guidance to complete it. Maybe ColinE66 is a better candidate to develop it.

List of revisions:
Code:

2020-07-06
- vbColorPicker Final

2020-07-02
- Add PopupPosition parameter to ShowEx function.
- Improved FrmColorPicker

Note:
Now the vbColorPicker is basically completed.

2020-07-01
- Completely rewrote FrmColorPicker

2020-06-30
- Add CreateBarSat (DreamManor -- RC5.Cairo)
- Add CreateRectSat (DreamManor -- RC5.Cairo)
- Add CreateRectSatAccelerate (DreamManor -- RC5.Cairo)
- Add CreateBarBri (DreamManor -- RC5.Cairo)
- Add CreateRectBri (DreamManor -- RC5.Cairo)
- Add CreateRectBriAccelerate (DreamManor -- RC5.Cairo)
- Add Only-Web-Colors Test-Option
- Improved SpinBox
- Add vbColorPicker: FrmColorPicker(Beta)

2020-06-28
- Add cUpDown.cls (DreamManor -- RC5.Cairo)
- Add SpinBox User Control (DreamManor)
- Add SpinBox Test Page (DreamManor)

2020-06-27 a.m.
- Create Rect Hue (DreamManor -- RC5.Cairo)
- Create Rect Hue (Acclerate) (DreamManor -- RC5.Cairo)
- Create Rect RGB (DreamManor -- RC5.Cairo)
- Add Speed Compare Module

2020-06-26
- Create Bar Hue (DreamManor -- RC5.Cairo)
- Create Bar RGB (DreamManor -- RC5.Cairo)
- Create Rect RGB (Acclerate) (DreamManor -- RC5.Cairo)

2020-06-25 p.m.
- Draw border on a picture(DreamManor -- RC5.Cairo)
- Draw bar selector (DreamManor -- RC5.Cairo)
- Draw bar selector (Olaf -- Best Practice)
- Draw rect marker (DreamManor -- RC5.Cairo)

2020-06-25
- First released learning/rewriting framework

Attached Images
 
Attached Files
Viewing all 1304 articles
Browse latest View live




Latest Images