This will create and add a project folder with selected sub folders(Usercontrol,Classes,Modules,etc).
↧
VB6 Project Folder Creator
↧
VB6 Locks up at breakpoint in Windows 10
I've got VB6 installed and running in Windows 10 after following some tips.
Unfortunately, it doesn't behave right.
For example, when I set a BREAKPOINT and then RUN the app, it stops at the breakpoint, highlights it normally, but then I can't do anything else. It just 'dings' whenever I click on something.
I've set compatibility to XP, win7, and Run as Admin with no success.
I also notice the Inspect window opens in another monitor (I have 3 monitor setup).
Any suggestions?
TIA
Unfortunately, it doesn't behave right.
For example, when I set a BREAKPOINT and then RUN the app, it stops at the breakpoint, highlights it normally, but then I can't do anything else. It just 'dings' whenever I click on something.
I've set compatibility to XP, win7, and Run as Admin with no success.
I also notice the Inspect window opens in another monitor (I have 3 monitor setup).
Any suggestions?
TIA
↧
↧
User Control Assistant 2
This is a remake of my previous submission. You can now generate all properties at the same time, except for Font property, which uses a separate button . Lists can be edited to your needs. Hope this app is helpful to someone. Updated: You can now Load / Save plus a few other additions like Line Count etc. Another update 8/3/2021, can now edit the properties and add up to 5 events. Hopefully I haven't added any bugs.
If this app is working for you , I'd like to hear about it . Thanks and enjoy.
If this app is working for you , I'd like to hear about it . Thanks and enjoy.
↧
PicServer as Service
PicServer has been made into a service. It is quite a bit more complex than the original, and is called PicSvc.
PicSvc requires the use of NTSVC.ocx. To allow some trouble shooting in the IDE, PicSvc can be run as a Desktop application as well. To create the service, change the IsService flag to true and compile as PicSvc.exe. Although PicSvc.exe can be installed/unistalled by running with a command line extension of /I or /U, you will need to setup some parameters. To accomplish this, a seoond program is required called PicSvcCtrl (prjInterface.vbp), which allows you to install, uninstall, setup, and start the service. The password maintenance portion is not functional yet. The thing to remember is that registry values for any service are automatically deleted when a service is uninstalled, and that the service must be stopped before it can be uninstalled. Also, PicSvc.exe must be in the same directory as PicSvCtrl.
After installing the service, run Setup. The second time around, the default settings will be borrowed from the Desktop version, but will get recreated for the service version.
Errors, connects, disconnects, and file access are logged to a daily logfile. When operating as a service, you will need a directory to serve as a location for the logfiles. A service needs a directory that is accessible to all users, and that is relegated to the "\Windows\System32\LogFiles\service" directory.
One important thing to remember about a service is that there can be no output to the screen, as it operates in session 0 with system privileges, and continues to operate even if you are logged off.
J.A. Coutts
PicSvc requires the use of NTSVC.ocx. To allow some trouble shooting in the IDE, PicSvc can be run as a Desktop application as well. To create the service, change the IsService flag to true and compile as PicSvc.exe. Although PicSvc.exe can be installed/unistalled by running with a command line extension of /I or /U, you will need to setup some parameters. To accomplish this, a seoond program is required called PicSvcCtrl (prjInterface.vbp), which allows you to install, uninstall, setup, and start the service. The password maintenance portion is not functional yet. The thing to remember is that registry values for any service are automatically deleted when a service is uninstalled, and that the service must be stopped before it can be uninstalled. Also, PicSvc.exe must be in the same directory as PicSvCtrl.
After installing the service, run Setup. The second time around, the default settings will be borrowed from the Desktop version, but will get recreated for the service version.
Errors, connects, disconnects, and file access are logged to a daily logfile. When operating as a service, you will need a directory to serve as a location for the logfiles. A service needs a directory that is accessible to all users, and that is relegated to the "\Windows\System32\LogFiles\service" directory.
One important thing to remember about a service is that there can be no output to the screen, as it operates in session 0 with system privileges, and continues to operate even if you are logged off.
J.A. Coutts
↧
System Wide Got/Lost Focus (subclassing)
This is just a small example of how one might accomplish system wide GotFocus and LostFocus events in VB6.
The way it's setup, it's fairly IDE safe. With the Comctl32 subclassing, there are only two cases that crash the IDE: 1) when you click the "End" button when you get a runtime error, and 2) when you use the IDE's "Stop" button while a modal form is showing. If you've got no modal forms, the IDE's stop button is safe.
Here's the code that must be placed in a BAS module:
And here's a small test for any form:
Notice that the GotFocusSystemWide/LostFocusSystemWide events must be declared as Public. This is true because of the late-binding of the form object in the subclass procedure.
-----------
And hey, if someone wants to rework this with one of the "completely IDE safe" thunks, that'd be absolutely fine with me.
The way it's setup, it's fairly IDE safe. With the Comctl32 subclassing, there are only two cases that crash the IDE: 1) when you click the "End" button when you get a runtime error, and 2) when you use the IDE's "Stop" button while a modal form is showing. If you've got no modal forms, the IDE's stop button is safe.
Here's the code that must be placed in a BAS module:
Code:
Option Explicit
'
Private Declare Function DefSubclassProc Lib "comctl32.dll" Alias "#413" (ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function SetWindowSubclass Lib "comctl32.dll" Alias "#410" (ByVal hWnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long, Optional ByVal dwRefData As Long) As Long
Private Declare Function RemoveWindowSubclass Lib "comctl32.dll" Alias "#412" (ByVal hWnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long) As Long
'
Private Declare Function vbaObjSetAddref Lib "msvbvm60.dll" Alias "__vbaObjSetAddref" (ByRef dstObject As Any, ByRef srcObjPtr As Any) As Long
'
Public Function SubclassForSystemFocus(frm As Form) As Long
SubclassForSystemFocus = SetWindowSubclass(frm.hWnd, AddressOf ProcForSystemFocus, frm.hWnd, ObjPtr(frm))
End Function
Public Function UnSubclassForSystemFocus(hWnd As Long) As Long
UnSubclassForSystemFocus = RemoveWindowSubclass(hWnd, AddressOf ProcForSystemFocus, hWnd)
End Function
Public Function ProcForSystemFocus(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long, ByVal uIdSubclass As Long, ByVal dwRefData As Long) As Long
Const WM_DESTROY As Long = &H2&
Const WM_SETFOCUS As Long = &H7&
Const WM_KILLFOCUS As Long = &H8&
'
Dim frm As VB.Form ' Used for our form's temporary "object" reference.
'
Select Case uMsg
Case WM_DESTROY
UnSubclassForSystemFocus hWnd
Case WM_SETFOCUS ' Did our form just GET the focus?
On Error Resume Next ' This prevents the IDE from crashing if the GotFocusSystemWide procedure doesn't exist.
vbaObjSetAddref frm, ByVal dwRefData ' Get an object reference for our form.
frm.GotFocusSystemWide ' Call our form's GotFocusSystemWide event, or let error handling do its thing.
On Error GoTo 0
Case WM_KILLFOCUS ' Did our form just LOSE the focus?
On Error Resume Next ' This prevents the IDE from crashing if the LostFocusSystemWide procedure doesn't exist.
vbaObjSetAddref frm, ByVal dwRefData ' Get an object reference for our form.
frm.LostFocusSystemWide ' Call our form's LostFocusSystemWide event, or let error handling do its thing.
On Error GoTo 0
End Select
ProcForSystemFocus = DefSubclassProc(hWnd, uMsg, wParam, lParam)
End Function
Code:
Option Explicit
Private Sub Form_Load()
SubclassForSystemFocus Me ' No need to unsubclass, as it's done automatically.
End Sub
Public Sub GotFocusSystemWide()
Debug.Print "I've got the focus."
' DON'T put any other user-interface in here, or you may create a perpetual loop.
' You're still basically in the subclass procedure when you're in here.
End Sub
Public Sub LostFocusSystemWide()
Debug.Print "I've lost the focus."
' DON'T put any other user-interface in here, or you may create a perpetual loop.
' You're still basically in the subclass procedure when you're in here.
End Sub
-----------
And hey, if someone wants to rework this with one of the "completely IDE safe" thunks, that'd be absolutely fine with me.
↧
↧
InputBox With Password mask,Get screen coordinate position of the input box
Code:
Private Sub Form_Load()
InputX = 300 * Screen.TwipsPerPixelX
InputY = 500 * Screen.TwipsPerPixelY
End Sub
Private Sub Command1_Click()
Dim S As String
S = InputboxXY("Please Input Your Password", , True, "Tip Info", InputX, InputY)
MsgBox "S=" & S
End SubCode:
Public InputX As Long, InputY As Long
Dim PassMode As Boolean
Dim FindInput As Boolean, InputTitle As String
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare Function IsWindowVisible Lib "user32" (ByVal hwnd As Long) As Long
Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Dim lngTimerID As Long
Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Public Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Public Const EM_SETPASSWORDCHAR = &HCC
Function InputboxXY(Optional Title As String, Optional Default As String, Optional PassModeA As Boolean, Optional Prompt As String, Optional XPos, Optional YPos)
If Title = "" Then Title = App.Title
InputTitle = Title
FindInput = False
PassMode = PassModeA
lngTimerID = SetTimer(0, 0, 15, AddressOf TimerProc)
If InputX > 0 Then XPos = InputX: YPos = InputY
If IsMissing(XPos) Then
InputboxXY = InputBox(Prompt, Title, Default)
Else
InputboxXY = InputBox(Prompt, Title, Default, XPos, YPos)
End If
End Function
Public Sub TimerProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long)
Static Rect1 As RECT
Dim win As Long, InputHwd As Long
win = FindWindow(vbNullString, InputTitle)
If win > 0 Then
If IsWindowVisible(win) Then
If FindInput = False Then
FindInput = True
If PassMode Then
InputHwd = FindWindowEx(win, 0, "edit", vbNullString)
SendMessage InputHwd, EM_SETPASSWORDCHAR, 42, 0
End If
End If
GetWindowRect win, Rect1
End If
ElseIf FindInput Then
KillTimer 0, lngTimerID
InputX = Rect1.Left * Screen.TwipsPerPixelX
InputY = Rect1.Top * Screen.TwipsPerPixelY
End If
End Sub↧
Adjust the size of the borderless window-VB6
Code:
Private Const WM_NCLBUTTONDOWN = &HA1
Private Const HTLEFT = 10
Private Const HTRIGHT = 11
Private Const HTTOP = 12
Private Const HTBOTTOM = 15
Private Const HTBOTTOMRIGHT = 17
Private Const HTBOTTOMLEFT = 16
Private Const HTTOPLEFT = 13
Private Const HTTOPRIGHT = 14
'sendmessage函数声明
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function SetCapture Lib "user32" (ByVal hwnd As Long) As Long
Private intEdge As Integer '临界距离，鼠标在离边框距离小于等于该值则判定在边框上
Private Sub Form_Load()
'相当于三个象素
intEdge = Me.ScaleX(3, vbPixels, Me.ScaleMode)
End Sub
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
'Critical:将处理四角的代码放在前面
If X + intEdge >= ScaleWidth And Y + intEdge >= ScaleHeight Then '右下角
ReleaseCapture
SendMessage hwnd, WM_NCLBUTTONDOWN, HTBOTTOMRIGHT, 0
ElseIf Y + intEdge >= ScaleHeight And X <= intEdge Then '左下角
ReleaseCapture
SendMessage hwnd, WM_NCLBUTTONDOWN, HTBOTTOMLEFT, 0
ElseIf Y <= intEdge And X <= intEdge Then '左上角
ReleaseCapture
SendMessage hwnd, WM_NCLBUTTONDOWN, HTTOPLEFT, 0
ElseIf Y <= intEdge And X + intEdge <= ScaleWidth Then '右上边
ReleaseCapture
SendMessage hwnd, WM_NCLBUTTONDOWN, HTTOPRIGHT, 0
ElseIf X + intEdge >= ScaleWidth And Y <= ScaleHeight Then '右边
ReleaseCapture
SendMessage hwnd, WM_NCLBUTTONDOWN, HTRIGHT, 0
ElseIf Y + intEdge >= ScaleHeight And X <= ScaleWidth Then '下边
ReleaseCapture
SendMessage hwnd, WM_NCLBUTTONDOWN, HTBOTTOM, 0
ElseIf X <= intEdge And Y <= ScaleHeight Then '左边
ReleaseCapture
SendMessage hwnd, WM_NCLBUTTONDOWN, HTLEFT, 0
ElseIf Y <= intEdge And X <= ScaleWidth Then '上边
ReleaseCapture
SendMessage hwnd, WM_NCLBUTTONDOWN, HTTOP, 0
End If
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
'Critical:将处理四角的代码放在前面
Label1.Caption = X & " " & Y
If (X + intEdge >= ScaleWidth And Y + intEdge >= ScaleHeight) Or (Y <= intEdge And X <= intEdge) Then '右下\左上角
MousePointer = vbSizeNWSE
ElseIf Y + intEdge >= ScaleHeight And X <= intEdge Or Y <= intEdge And X + intEdge <= ScaleWidth Then '左下\右上角
MousePointer = vbSizeNESW
ElseIf X + intEdge >= ScaleWidth And Y <= ScaleHeight Or X <= intEdge And Y <= ScaleHeight Then '左、右
MousePointer = vbSizeWE
ElseIf Y + intEdge >= ScaleHeight And X <= ScaleWidth Or Y <= intEdge And X <= ScaleWidth Then '上边下边
MousePointer = vbSizeNS
Else
MousePointer = vbNormal
End If
End Sub
Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
SetCapture hwnd
End Sub↧
VB6 Flip Digit Style Clock from the 70's
Very simple clock code with the graphics that look similar to the flip digit clocks from the 70's . Added the date just for grins
↧
Get Library Name by Com DLL with vb6
HOW to get Library Name by Com DLL with vb6?
from : Library info.-VBForums
https://www.vbforums.com/showthread....6-Library-info
Library Excel
c:\***\Office16\EXCEL.EXE
Microsoft Excel 16.0 Object Library
Library VSFlex8Ctl
C:\Program Files (x86)\Microsoft Visual Basic 6.0\v8.oca
ComponentOne VSFlexGrid 8.0 (OLEDB)
i used v8.ocx(VSFlexGrid),but why vb6 com typeinfo tool show:v8.oca??
' my result=VSFlex8 (ComponentOne VSFlexGrid 8.0 (OLEDB))
why vb6 show (Library VSFlex8Ctl)?
--------------------------------
need Reference=*\G{3181A65A-CC39-4CDE-A4DF-2E889E6F1AF1}#1.51#0#olelib1.81.tlb#Edanmo's OLE interfaces & functions v1.81
Object={BEEECC20-4D5F-4F8B-BFDC-5D9B6FBDE09D}#1.0#0; v8.ocx
Reference=*\G{00020813-0000-0000-C000-000000000046}#1.9#0#**\Office16\EXCEL.EXE#Microsoft Excel 16.0 Object Library
Reference=*\G{3181A65A-CC39-4CDE-A4DF-2E889E6F1AF1}#1.51#0#olelib1.81.tlb#Edanmo's OLE interfaces & functions v1.81
How is the reference part of the project file generated with code?
VSflexgrid8.oca
Library:VSFlex8Ctl (ComponentOne VSFlexGrid 8.0 (OLEDB))
VSflexgrid88.ocx
Library:VSFlex8 (ComponentOne VSFlexGrid 8.0 (OLEDB))
(VSflexgrid8.ocx There is no event list, VSflexgrid8.oca has 2 sets of event objects，_iVSFlexgridEvents,_Event0）
from : Library info.-VBForums
https://www.vbforums.com/showthread....6-Library-info
Library Excel
c:\***\Office16\EXCEL.EXE
Microsoft Excel 16.0 Object Library
Library VSFlex8Ctl
C:\Program Files (x86)\Microsoft Visual Basic 6.0\v8.oca
ComponentOne VSFlexGrid 8.0 (OLEDB)
i used v8.ocx(VSFlexGrid),but why vb6 com typeinfo tool show:v8.oca??
Code:
'need Reference=*\G{3181A65A-CC39-4CDE-A4DF-2E889E6F1AF1}#1.51#0#olelib1.81.tlb#Edanmo's OLE interfaces & functions v1.81
Dim Path As String
Path = "C:\Program Files (x86)\Microsoft Visual Basic 6.0\v8.ocx"
Dim locLib As ITypeLib
Dim Name As String
Dim Desc As String
On Error Resume Next
Set locLib = LoadTypeLibEx(Path, REGKIND_NONE)
If Err.Number Then Err.Clear: Exit Sub
On Error GoTo 0
locLib.GetDocumentation -1, Name, Desc, 0, vbNullString
InputBox "", "", Name & " (" & Desc & ")"why vb6 show (Library VSFlex8Ctl)?
--------------------------------
need Reference=*\G{3181A65A-CC39-4CDE-A4DF-2E889E6F1AF1}#1.51#0#olelib1.81.tlb#Edanmo's OLE interfaces & functions v1.81
Object={BEEECC20-4D5F-4F8B-BFDC-5D9B6FBDE09D}#1.0#0; v8.ocx
Reference=*\G{00020813-0000-0000-C000-000000000046}#1.9#0#**\Office16\EXCEL.EXE#Microsoft Excel 16.0 Object Library
Reference=*\G{3181A65A-CC39-4CDE-A4DF-2E889E6F1AF1}#1.51#0#olelib1.81.tlb#Edanmo's OLE interfaces & functions v1.81
How is the reference part of the project file generated with code?
VSflexgrid8.oca
Library:VSFlex8Ctl (ComponentOne VSFlexGrid 8.0 (OLEDB))
VSflexgrid88.ocx
Library:VSFlex8 (ComponentOne VSFlexGrid 8.0 (OLEDB))
(VSflexgrid8.ocx There is no event list, VSflexgrid8.oca has 2 sets of event objects，_iVSFlexgridEvents,_Event0）
↧
↧
vb6 everything SDK,quick Search file for vb6,vba
Need Run EveryThing.exe First !
it's support x64 everything.exe,but un suppot about:Lite version
Download Portable Zip 64-bit,it's only 2 files,it's funny
(Everything.exe,Everything.lng),it's support ipc, VB6 Everything SDK
'Note: sample copied from https://www.voidtools.com/support/ev.../visual_basic/
https://www.voidtools.com/Everything-SDK.zip
Everything-SDK\dll\Everything32.dll
vb6 sdk
x64 vba sdk:
it's support x64 everything.exe,but un suppot about:Lite version
Download Portable Zip 64-bit,it's only 2 files,it's funny
(Everything.exe,Everything.lng),it's support ipc, VB6 Everything SDK
'Note: sample copied from https://www.voidtools.com/support/ev.../visual_basic/
https://www.voidtools.com/Everything-SDK.zip
Everything-SDK\dll\Everything32.dll
vb6 sdk
Code:
'it's VB6 Everything SDK
'VB.net and the Everything SDK - voidtools forum
'https://www.voidtools.com/forum/viewtopic.php?f=10&t=5550
Option Explicit
Public Declare Function Everything_SetSearchA Lib "Everything32.dll" (ByVal ins As String) As Long
Public Declare Function Everything_QueryA Lib "Everything32.dll" (ByVal bWait As Long) As Long
Public Declare Function Everything_SetSearchW Lib "Everything32.dll" (ByVal ins As Long) As Long
Public Declare Function Everything_SetRequestFlags Lib "Everything32.dll" (ByVal dwRequestFlags As Long) As Long
Public Declare Function Everything_QueryW Lib "Everything32.dll" (ByVal bWait As Long) As Long
Public Declare Function Everything_GetNumResults Lib "Everything32.dll" () As Long
Public Declare Function Everything_GetResultFileNameW Lib "Everything32.dll" (ByVal index As Long) As Long
Public Declare Function Everything_GetLastError Lib "Everything32.dll" () As Long
Public Declare Function Everything_GetResultFullPathNameW Lib "Everything32.dll" (ByVal index As Long, ByVal ins As Long, ByVal size As Long) As Long
Public Declare Function Everything_GetResultSize Lib "Everything32.dll" (ByVal index As Long, ByRef size As Long) As Long 'size UInt64
Public Declare Function Everything_GetResultDateModified Lib "Everything32.dll" (ByVal index As Long, ByRef ft As Long) As Long 'ft UInt64
Public Const EVERYTHING_REQUEST_FILE_NAME = &H1
Public Const EVERYTHING_REQUEST_PATH = &H2
Public Const EVERYTHING_REQUEST_FULL_PATH_AND_FILE_NAME = &H4
Public Const EVERYTHING_REQUEST_EXTENSION = &H8
Public Const EVERYTHING_REQUEST_SIZE = &H10
Public Const EVERYTHING_REQUEST_DATE_CREATED = &H20
Public Const EVERYTHING_REQUEST_DATE_MODIFIED = &H40
Public Const EVERYTHING_REQUEST_DATE_ACCESSED = &H80
Public Const EVERYTHING_REQUEST_ATTRIBUTES = &H100
Public Const EVERYTHING_REQUEST_FILE_LIST_FILE_NAME = &H200
Public Const EVERYTHING_REQUEST_RUN_COUNT = &H400
Public Const EVERYTHING_REQUEST_DATE_RUN = &H800
Public Const EVERYTHING_REQUEST_DATE_RECENTLY_CHANGED = &H1000
Public Const EVERYTHING_REQUEST_HIGHLIGHTED_FILE_NAME = &H2000
Public Const EVERYTHING_REQUEST_HIGHLIGHTED_PATH = &H4000
Public Const EVERYTHING_REQUEST_HIGHLIGHTED_FULL_PATH_AND_FILE_NAME = &H8000
Public Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Public Type SYSTEMTIME
wYear As Long
wMonth As Long
wDayOfWeek As Long
wDay As Long
wHour As Long
wMinute As Long
wSecond As Long
wMilliseconds As Long
End Type
Private Declare Function FileTimeToSystemTime Lib "kernel32" (ByRef ft As Long, lpSystemTime As SYSTEMTIME) As Long
Private Declare Function SystemTimeToTzSpecificLocalTime Lib "kernel32" (ByVal tzi As Long, lpst As SYSTEMTIME, lplt As SYSTEMTIME) As Long
Private Declare Function SystemTimeToVariantTime Lib "OLEAUT32.DLL" (lpSystemTime As SYSTEMTIME, vtime As Date) As Long
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Function CheckEverythingRunning() As Boolean
Dim FindOK As Boolean
Dim Hwnd As Long
Hwnd = FindWindow("EVERYTHING", "Everything")
CheckEverythingRunning = Hwnd <> 0
End Function
Sub SimpleTest()
If Not CheckEverythingRunning Then
Debug.Print "Please check Everything Is Running"
Exit Sub
End If
Dim EyText As String
Dim test As Boolean
EyText = "Everything"
Call Everything_SetSearchW(StrPtr(EyText))
'Call Everything_SetSearchA(EyText)
Everything_SetRequestFlags (EVERYTHING_REQUEST_FILE_NAME Or EVERYTHING_REQUEST_PATH Or EVERYTHING_REQUEST_SIZE Or EVERYTHING_REQUEST_DATE_MODIFIED)
test = Everything_QueryW(True)
'test = Everything_QueryA(True)
If Not test Then
Debug.Print "Search Err:Please check Everything Is Running"
Exit Sub
End If
Dim NumResults As Long
Dim i As Long
Dim filename2 As String
Dim filesize As Long
Dim size As Long
Dim ftdm As Long
Dim stdm As SYSTEMTIME
Dim ltdm As SYSTEMTIME
Dim DateModified As Date
Dim ID As Long
NumResults = Everything_GetNumResults()
Debug.Print "Find FILES:" & NumResults
filename2 = String(260, 0)
If NumResults > 0 Then
For i = 0 To NumResults - 1
test = Everything_GetResultFullPathNameW(i, StrPtr(filename2), 260)
ID = InStr(filename2, Chr(0))
If ID > 0 Then
FileName = Left(filename2, ID - 1)
Else
FileName = filename2
End If
test = Everything_GetResultSize(i, size)
test = Everything_GetResultDateModified(i, ftdm)
test = FileTimeToSystemTime(ftdm, stdm)
test = SystemTimeToTzSpecificLocalTime(0, stdm, ltdm)
test = SystemTimeToVariantTime(ltdm, DateModified)
Debug.Print DateModified & "//" & size & "//" & FileName
Next
End If
End Subx64 vba sdk:
Code:
'Replaced for VBA usage
' - UINT32 with LONG
' - UINT64 with LONGLONG
' - INTPtr with LONGPtr
' - System.Text.StringBuilder with String
' - System.DateTime with String
' - filename.Capacity with filesize
Public Declare PtrSafe Function Everything_SetSearchW Lib "C:\SDK\Everything64.dll" (ByVal ins As LongPtr) As Long
Public Declare PtrSafe Function Everything_SetRequestFlags Lib "C:\SDK\Everything64.dll" (ByVal dwRequestFlags As Long) As Long
Public Declare PtrSafe Function Everything_QueryW Lib "C:\SDK\Everything64.dll" (ByVal bWait As Integer) As Integer
Public Declare PtrSafe Function Everything_GetNumResults Lib "C:\SDK\Everything64.dll" () As Long
Public Declare PtrSafe Function Everything_GetResultFileNameW Lib "C:\SDK\Everything64.dll" (ByVal index As Long) As LongPtr
Public Declare PtrSafe Function Everything_GetLastError Lib "C:\SDK\Everything64.dll" () As Long
Public Declare PtrSafe Function Everything_GetResultFullPathNameW Lib "C:\SDK\Everything64.dll" (ByVal index As Long, ByVal ins As LongPtr, ByVal size As Long) As Long
Public Declare PtrSafe Function Everything_GetResultSize Lib "C:\SDK\Everything64.dll" (ByVal index As Long, ByRef size As LongLong) As Integer 'size UInt64
Public Declare PtrSafe Function Everything_GetResultDateModified Lib "C:\SDK\Everything64.dll" (ByVal index As Long, ByRef ft As LongLong) As Integer 'ft UInt64
Public Const EVERYTHING_REQUEST_FILE_NAME = &H1
Public Const EVERYTHING_REQUEST_PATH = &H2
Public Const EVERYTHING_REQUEST_FULL_PATH_AND_FILE_NAME = &H4
Public Const EVERYTHING_REQUEST_EXTENSION = &H8
Public Const EVERYTHING_REQUEST_SIZE = &H10
Public Const EVERYTHING_REQUEST_DATE_CREATED = &H20
Public Const EVERYTHING_REQUEST_DATE_MODIFIED = &H40
Public Const EVERYTHING_REQUEST_DATE_ACCESSED = &H80
Public Const EVERYTHING_REQUEST_ATTRIBUTES = &H100
Public Const EVERYTHING_REQUEST_FILE_LIST_FILE_NAME = &H200
Public Const EVERYTHING_REQUEST_RUN_COUNT = &H400
Public Const EVERYTHING_REQUEST_DATE_RUN = &H800
Public Const EVERYTHING_REQUEST_DATE_RECENTLY_CHANGED = &H1000
Public Const EVERYTHING_REQUEST_HIGHLIGHTED_FILE_NAME = &H2000
Public Const EVERYTHING_REQUEST_HIGHLIGHTED_PATH = &H4000
Public Const EVERYTHING_REQUEST_HIGHLIGHTED_FULL_PATH_AND_FILE_NAME = &H8000
Public Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Public Type SYSTEMTIME
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type
Private Declare PtrSafe Function FileTimeToSystemTime Lib "kernel32" (ByRef ft As LongLong, lpSystemTime As SYSTEMTIME) As Long
Private Declare PtrSafe Function SystemTimeToTzSpecificLocalTime Lib "kernel32" (ByVal tzi As LongPtr, lpst As SYSTEMTIME, lplt As SYSTEMTIME) As Long
Private Declare PtrSafe Function SystemTimeToVariantTime Lib "OLEAUT32.DLL" (lpSystemTime As SYSTEMTIME, vtime As Date) As Long
Sub SimpleTest()
Dim EyText As String
Dim test As Boolean
EyText = "Everything"
Everything_SetSearchW (StrPtr(EyText))
Everything_SetRequestFlags (EVERYTHING_REQUEST_FILE_NAME Or EVERYTHING_REQUEST_PATH Or EVERYTHING_REQUEST_SIZE Or EVERYTHING_REQUEST_DATE_MODIFIED)
test = Everything_QueryW(True)
Debug.Print test
Dim NumResults As Long
Dim i As Long
Dim filename As String
Dim filesize As Long
Dim size As LongLong
Dim ftdm As LongLong
Dim stdm As SYSTEMTIME
Dim ltdm As SYSTEMTIME
Dim DateModified As Date
filename = String(260, 0)
NumResults = Everything_GetNumResults()
Debug.Print NumResults
If NumResults > 0 Then
For i = 0 To NumResults - 1
test = Everything_GetResultFullPathNameW(i, StrPtr(filename), 260)
Debug.Print filename
test = Everything_GetResultSize(i, size)
Debug.Print size
test = Everything_GetResultDateModified(i, ftdm)
test = FileTimeToSystemTime(ftdm, stdm)
test = SystemTimeToTzSpecificLocalTime(0, stdm, ltdm)
test = SystemTimeToVariantTime(ltdm, DateModified)
Debug.Print DateModified
Next
End If
End Sub↧
VB6 Rolling3Digits BitBlt
Just threw this together to have something to do . Does'nt really do much, but looks neat. It can only display numbers not add or subtract. Maybe someone will find something useful in it. Maybe even make it actually add and subtract.
↧
Edge Webview2 Automatic installation, detect the installed version
Code:
Function CheckSetupOk() As Boolean
'It takes 10 seconds to check whether the edge runtime component is installed successfully. Is there a faster method?
Dim WV As cWebView2
Set WV = New_c.WebView2
CheckSetupOk = WV.BindTo(Me.hWnd) <> 0
Set WV = Nothing
End Function
Function DonwSetupTool() As Boolean
Dim URL As String
URL = "https://go.microsoft.com/fwlink/p/?LinkId=2124703"
'xmlhttp download***
'save as :Edge_Webview2RunTime.exe
Dim Size1 As Long
Size1 = FileLen(App.Path & "\Edge_Webview2RunTime.exe")
DonwSetupTool = Size1 > 1024 ^ 2
end functionI dont know if there is a silent installation parameter to prevent him from displaying the download and installation interface
MicrosoftEdgeWebview2Setup.exe /silent /install
check Registry information：
Microsoft Edge WebView2 Runtim(92.0.902.8)
HKEY_LOCAL_MACHINE\SOFTWARE\WOW6432Node\Microsoft\EdgeUpdate\Clients\{F3017226-FE2A-4295-8BDF-00C3A9A7E4C5}
get string value(PV and name)
Can be used with：VB6 WebView2-Binding (Edge-Chromium)-VBForums
https://www.vbforums.com/showthread....Edge-Chromium)
↧
Check if it is a 64-bit operating system
Code:
Private Declare Function GetModuleHandle Lib _
"kernel32" Alias "GetModuleHandleA" ( _
ByVal lpModuleName As String) As Long
Private Declare Function LoadLibrary Lib _
"kernel32" Alias "LoadLibraryA" ( _
ByVal lpLibFileName As String) As Long
Private Declare Function GetProcAddress Lib _
"kernel32" (ByVal hModule As Long, _
ByVal lpProcName As String) As Long
Private Declare Function FreeLibrary Lib _
"kernel32" (ByVal hLibModule As Long) As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Function IsWow64Process Lib "kernel32" (ByVal hProcess As Long, ByRef Wow64Process As Long) As Long
Function IsX64b() As Boolean
Dim hMod As Long
hMod = GetModuleHandle("ntdll.dll")
If GetProcAddress(hMod, "ZwWow64ReadVirtualMemory64") Then
IsX64b = True
End If
End Function
Function IsX64() As Boolean
Dim lngReturn As Long
'GetCurrentProcess
Call IsWow64Process(-1, lngReturn)
IsX64 = lngReturn <> 0
End Function↧
↧
VB6 Call Web Api GET
Hello friends:wave:
I had a question about contacting the api :
Connect via winhtt 5.1
I set up a connection and receive information from the web, but all at once I want to see if there is a way to receive the data separately!?
![Name: Untitled.png
Views: 33
Size: 13.0 KB]()
As you can see in the picture, all the data is in one text box. Is it possible to put each data in a separate text box?
for example:
Text1.text=symbol
Text2.text=name
I had a question about contacting the api :
Connect via winhtt 5.1
I set up a connection and receive information from the web, but all at once I want to see if there is a way to receive the data separately!?
HTML Code:
Option Explicit
Private Sub GET_Click()
Dim httpURL As Object
Dim Mojtaba As String
Dim Texto As String
Set httpURL = CreateObject("WinHttp.WinHttpRequest.5.1")
Set httpURL = New WinHttp.WinHttpRequest
Mojtaba = "https://api.coingecko.com/api/v3/coins/markets?vs_currency=usd&order=market_cap_desc&per_page=1&page=1"
httpURL.Open "GET", Mojtaba
httpURL.Send
Text1 = httpURL.ResponseText
End SubAs you can see in the picture, all the data is in one text box. Is it possible to put each data in a separate text box?
for example:
Text1.text=symbol
Text2.text=name
↧
hook createProcess with wmi
Code:
Private Sub Command2_Click()
Check1.Value = 0
End Sub
Private Sub Command1_Click()
'ADD CONTROLS:Command1,Command2,List1,check1
Check1.Value = 1
strComputer = "."
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2:Win32_Process")
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Set colProcesses = objWMIService.ExecNotificationQuery _
("SELECT * FROM __instancecreationevent " _
& " Within 1 Where TargetInstance ISA 'Win32_Process'")
On Error Resume Next
Dim objProcess As Object
Dim A As String
Do While Check1.Value = 1
DoEvents
If Check1.Value = 0 Then Exit Sub
Set objProcess = Nothing
Set objProcess = colProcesses.NextEvent(10)
If Not objProcess Is Nothing Then
A = objProcess.TargetInstance.Caption
i = i + 1
List1.AddItem i & "--" & A
Debug.Print A
End If
DoEvents
Loop
End SubCode:
Do While Check1.Value = 1
Set objProcess = colProcesses.NextEvent()
A = objProcess.TargetInstance.Caption
loop.ParentProcessId who create it
.Handle IS PROCESS ID
With objProcess.TargetInstance
A = .Caption & "/" & .Handle & "/Create BY:" & .ParentProcessId
End With
'Notepad.exe/17964/Create BY:17744 (EXPLORER.EXE)
↧
Super fast running image rotation
This is the first method, which is slower and has no extra white edges. The second method is faster
Code:
Private Type Bitmap
bmType As Long 'Image type: 0 means bitmap
bmWidth As Long 'Image width (pixels)
bmHeight As Long 'image height (pixels)
bmWidthBytes As Long 'The number of bytes per line of image
bmPlanes As Integer 'The number of layers of the image
bmBitsPixel As Integer 'The number of bits of the image
bmBits As Long 'Bitmap memory pointer
End Type
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function GetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long
Private Declare Function SetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long
Dim ctP180 As Double
'Need to place the following 6 controls on the form, all controls do not need to set any properties (including position and size), all adopt the default settings:
'Command1, Command2, Label1, Picture1, Text1, Combo1
Private Sub Form_Load()
Me.Caption = "Picture Rotation-Fast"
Text1.Text = App.Path & "\cat.jpg"
Command1.Caption = "Open": Command2.Caption = "Rotate"
Label1.Caption = "Rotation Angle": Label1.BackStyle = 0
Me.ScaleMode = 3: Picture1.ScaleMode = 3
Picture1.AutoSize = True: Picture1.AutoRedraw = True
Picture1.ToolTipText = "Double-click to restore the original graphic"
ctP180 = 4 * Atn(1) 'Pi
For i = -18 To 18
If i < 0 Then
Combo1.AddItem i * 10 & "degree"
Else
Combo1.AddItem "" & i * 10 & "degree"
End If
Next
Combo1.Text = "30 degrees"
'Set the control position, which can actually be done when designing the form
Dim W1 As Long
W1 = Me.TextWidth("A")
Command1.Move W1, W1, W1 * 6, W1 * 3: Text1.Move W1 * 8, W1, W1 * 80, W1 * 3
Command2.Move W1, W1 * 5, W1 * 6, W1 * 3: Label1.Move W1 * 8, W1 * 5.5, W1 * 11, W1 * 3
Combo1.Move W1 * 16, W1 * 5, W1 * 12
Picture1.Move W1, W1 * 9, W1 * 40, W1 * 40
Picture1.Picture = LoadPicture(Text1.Text)
'Call RndImg(Picture1)'Draw some images randomly
End Sub
Private Sub RndImg(Kj As Object)
'Draw some images randomly
Dim i As Long
Randomize
Kj.DrawWidth = 3
For i = 1 To 100
Kj.Line (Kj.ScaleWidth * Rnd, Kj.ScaleHeight * Rnd)-Step(50, 50), &HFFFFFF * Rnd, BF
Kj.Circle (Kj.ScaleWidth * Rnd, Kj.ScaleHeight * Rnd), 30 * Rnd, &HFFFFFF * Rnd
Next
Kj.Font.size = 24: Kj.Font.Bold = True
Kj.CurrentX = 10: Kj.CurrentY = 10: Kj.ForeColor = &H777777
Kj.Print Me.Caption
Kj.CurrentX = 11: Kj.CurrentY = 11: Kj.ForeColor = RGB(0, 110, 110)
Kj.Print Me.Caption
Kj.Line (0, 0)-(Kj.ScaleWidth - 1, Kj.ScaleHeight - 1), 255, B
Kj.DrawWidth = 1: Picture1.ForeColor = 0 'Restore to default settings
Picture1.Font.size = 9: Picture1.Font.Bold = False
Kj.Picture = Kj.Image
End Sub
Private Sub Command1_Click()
'Open picture file
Dim F As String
On Error GoTo Err1
F = Trim(Text1.Text)
Picture1.Picture = LoadPicture(F)
Exit Sub
Err1:
MsgBox "Unable to read file:" & vbCrLf & F, vbInformation
End Sub
Private Sub Combo1_Click()
Call Command2_Click
End Sub
Private Sub Command2_Click()
'Rotate the picture
Dim W1 As Long, H1 As Long, B1() As Byte, Bs1 As Long, BytesW1 As Long, Ps1 As Long
Dim W2 As Long, H2 As Long, B2() As Byte, Bs2 As Long, BytesW2 As Long, Ps2 As Long
Dim S1 As Long, S2 As Long, x As Long, y As Long, x1 As Long, y1 As Long
Dim CenX1 As Long, CenY1 As Long, CenX2 As Long, CenY2 As Long
Dim KjFocus As Control, ToJ As Single
ToJ = Val(Combo1.Text) / 180 * ctP180 'Rotation angle to radians
Set KjFocus = Me.ActiveControl 'memory the control with focus
Command1.Enabled = False: Command2.Enabled = False: Combo1.Enabled = False
'The following statement seems dispensable, but actually has two functions: restore the original image and size of the control before rotating
Picture1.Picture = Picture1.Picture
'Image data before rotation: width, height, color array, total bytes, bytes per row, bytes per pixel
GetBmpDat Picture1, W1, H1, B1, Bs1, BytesW1, Ps1
CenX1 = Int(W1 * 0.5): CenY1 = Int(H1 * 0.5) 'Image center point before rotation
'Calculate the height and width of the control after rotation, and set the ScaleMode of the form and picture to 3 (pixels) in advance
W2 = Abs(W1 * Cos(ToJ)) + Abs(H1 * Sin(ToJ)) 'After rotating: image width
H2 = Abs(H1 * Cos(ToJ)) + Abs(W1 * Sin(ToJ)) 'After rotating: image height
x = Picture1.Width - Picture1.ScaleWidth 'Picture frame border: width
y = Picture1.Height - Picture1.ScaleHeight 'Picture frame border: height
Picture1.Move Picture1.Left, Picture1.Top, x + W2, y + H2
'The function of the Picture1.Cls statement below is not to clear the image, but to update the control
'Image property, so that the image data can be obtained correctly when calling GetBmpDat
Picture1.Cls
Picture1.Line (0, 0)-(W2, H2), &HFFFFFF, BF
'Image data after rotation: width, height, color array, total bytes, bytes per row, bytes per pixel
GetBmpDat Picture1, W2, H2, B2, Bs2, BytesW2, Ps2
CenX2 = Int(W2 * 0.5): CenY2 = Int(H2 * 0.5) 'After rotation: image center point
'Display information
Picture1.CurrentX = 5: Picture1.CurrentY = 5
Picture1.Print "Processing, please wait..."
Me.Refresh
W1 = W1 - 1: H1 = H1 - 1
For x = 0 To W2 - 1
For y = 0 To H2 - 1
Zhuan -ToJ, CenX2, CenY2, x, y, x1, y1 'Use x1, y1 to get the rotated coordinates
x1 = x1 - CenX2 + CenX1: y1 = y1 - CenY2 + CenY1 'converted to the coordinates before rotation
S2 = XYtoIndex(x, y, BytesW2, Ps2) 'After rotation: the index of the pixel in the array B2
If x1 < 0 Or x1 > W1 Or y1 < 0 Or y1 > H1 Then
B2(S2 + 2) = 255: B2(S2 + 1) = 255: B2(S2) = 255 'Exceed the original image area, set to white
Else
S1 = XYtoIndex(x1, y1, BytesW1, Ps1) 'Before rotation: the index of the pixel in the array B1
B2(S2 + 2) = B1(S1 + 2): B2(S2 + 1) = B1(S1 + 1): B2(S2) = B1(S1) 'Red, Green and Blue
End If
Next
Next
SetBitmapBits Picture1.Image, Bs2, B2(0) 'Set the image of Picture1 to the rotated binary array B2()
Command1.Enabled = True: Command2.Enabled = True: Combo1.Enabled = True
On Error Resume Next
KjFocus.SetFocus 'Restore the control with focus
End Sub
Private Sub GetBmpDat(Kj As Control, W As Long, H As Long, B() As Byte, Bs As Long, BytesW As Long, Ps As Long)
'Get the image data of the control Kj
Dim MapInf As Bitmap
GetObject Kj.Image, Len(MapInf), MapInf 'Use MapInf to get the image information of Kj
W = MapInf.bmWidth: H = MapInf.bmHeight 'Image width, height (pixels)
BytesW = MapInf.bmWidthBytes 'The number of bytes occupied by each line
Ps = BytesW \ W 'The number of bytes per pixel (usually 4)
Bs = W * H * Ps 'Total number of bytes = width * height * bytes per pixel
ReDim B(0 To Bs - 1)
GetBitmapBits Kj.Image, Bs, B(0) 'Read the color values ??of all pixels of the Kj image into the binary array B()
End Sub
Private Function XYtoIndex(x As Long, y As Long, BytesW As Long, Ps As Long) As Long
'Return the number position of the image coordinates x,y in the color array.
'BytesW: the number of bytes occupied by each line of image, Ps: the number of bytes occupied by each pixel (usually 4)
XYtoIndex = y * BytesW + x * Ps
End Function
Private Sub Zhuan(ToJ As Single, x0 As Long, y0 As Long, ByVal x As Long, ByVal y As Long, x1 As Long, y1 As Long)
'Rotate the point x, y clockwise around x0, y0 by ToJ radians, and use x1, y1 to return the rotated position
'Note: To set the pi ratio in advance ctP180 = 4 * Atn(1)
Dim S As Single, J As Single
x = x - x0: y = y - y0
S = Sqr(x ^ 2 + y ^ 2) 'The distance between X,Y and x0,y0
If S = 0 Then J = 0 Else J = y / S 'Sine of the angle between the horizontal line
If Abs(J) >= 1 Then
If J > 0 Then J = ctP180 * 0.5 Else J = -ctP180 * 0.5
'Special case at 90 degrees
Else
J = Atn(J / Sqr(-J * J + 1)) 'The angle between the horizontal line
End If
If x < 0 Then J = -ctP180 - J
x1 = x0 + S * Cos(J + ToJ): y1 = y0 + S * Sin(J + ToJ) 'Return to the rotated position
End Sub
Private Sub Picture1_DblClick()
'The following statement seems dispensable, but actually has two functions: restore the original image and size of the control before rotating
Picture1.Picture = Picture1.Picture
End Sub↧
Crop Filter: Crop Picture
Code:
Dim Img 'As ImageFile
Dim IP 'As ImageProcess
Set Img = CreateObject("WIA.ImageFile")
Set IP = CreateObject("WIA.ImageProcess")
Img.LoadFile "C:\WINDOWS\Web\Wallpaper\Bliss.bmp"
IP.Filters.Add IP.FilterInfos("Crop").FilterID
IP.Filters(1).Properties("Left") =left
IP.Filters(1).Properties("Top") =top
IP.Filters(1).Properties("Right") = right
IP.Filters(1).Properties("Bottom") = bottom
Set Img = IP.Apply(Img)
Img.SaveFile "C:\WINDOWS\Web\Wallpaper\BlissCrop.bmp"↧
↧
VB6-Adodc1.Recordset.ActiveConnection.Execute Sql
Code:
Adodc1.ConnectionString = "provider=microsoft.jet.oledb.4.0;data source=" & App.Path & "\test.mdb"
Adodc1.RecordSource = "select * from usertable"
Adodc1.Refresh
Adodc1Execute "UPDATE Usertable SET Usertable.[Password] = 'abc2" & Now & "' WHERE UserName='user1'"
Function Adodc1Execute(Sql As String)
'On Error GoTo err
Adodc1.Recordset.ActiveConnection.Execute Sql
Adodc1.Recordset.ActiveConnection.Close
Adodc1.Refresh
' Adodc1.Refresh
' DataGrid1.Refresh
' Adodc1.Refresh
Exit Function
err:
MsgBox err.Description
End Function↧
Convert image files to JPG format BY WIA
Code:
Function WiaSaveAsJpg(LoadFile1 As String, SaveJpgFile As String, Optional JpgQuality As Long = 85, Optional ErrInfo As String) As Boolean
On Error GoTo Err1
Dim Img 'As ImageFile
Dim IP 'As ImageProcess
Set Img = CreateObject("WIA.ImageFile")
Set IP = CreateObject("WIA.ImageProcess")
Img.LoadFile LoadFile1
IP.Filters.Add IP.FilterInfos("Convert").FilterID
IP.Filters(1).Properties("FormatID").Value = wiaFormatJPEG
IP.Filters(1).Properties("Quality").Value = JpgQuality
Set Img = IP.Apply(Img)
Img.SaveFile SaveJpgFile
WiaSaveAsJpg = True
Exit Function
Err1:
ErrInfo = Err.Number & "," & Err.Description
End Function↧
Cookie Twist - Rotate circular selection
The effect is to let the user define a round "cookie" selection in an image and then "twist" it -180 to 180 degrees.
Unzip into a folder. Copy a large picture into the Project folder and rename it "sample.jpg" or update this line:
The "work image" is scaled to fit the Form. You can click the Restore button in the caption bar and then drag to resize the Form as usual.
That actual clipping and rotation occurs on the original image however, which can be larger or smaller than the area displayed within the Form.
The user interface isn't very refined, but should give you the idea. The scale factor in % is displayed in the caption bar to give you some idea of the scaling that is active.
The Pic object holds the original or edited image, so you can use any code you can already find here in the CodeBank for saving a bitmap-type IPicture/StdPicture to disk with or without compression. Even VB's SavePicture works, though it can only save as an uncompressed BMP image file.
Unzip into a folder. Copy a large picture into the Project folder and rename it "sample.jpg" or update this line:
Code:
Private Const SAMPLE_PIC_FILE As String = "sample.jpg"- Run the program.
- Make a circular selection by left-clicking at the center then dragging out to establish the radius.
- Then you can use the Up/Down control to set a rotation angle in degrees.
- After that you can click on the rotation Command button linked to the Up/Down to perform the desired rotation.
- Make a new selection, or click on the Reload button.
The "work image" is scaled to fit the Form. You can click the Restore button in the caption bar and then drag to resize the Form as usual.
That actual clipping and rotation occurs on the original image however, which can be larger or smaller than the area displayed within the Form.
The user interface isn't very refined, but should give you the idea. The scale factor in % is displayed in the caption bar to give you some idea of the scaling that is active.
The Pic object holds the original or edited image, so you can use any code you can already find here in the CodeBank for saving a bitmap-type IPicture/StdPicture to disk with or without compression. Even VB's SavePicture works, though it can only save as an uncompressed BMP image file.
↧