VBA DYNAMIC DROPDOWN MENU
EXCEL SELECTION VBA DROPDOWN MENU
Schneller und effizienter als Excel interne Dropdown Liste, Echtzeitsuche Search-Engine, Einfach zu installieren, Suchergebnis Zähler, Zugriffsbereiche einfach definieren, performance Excel Auswahlmenü
Faster and contacts than Excel internal drop-down list, real search engine, easy to remove, searchable counter, access conditions easy to use, performance Excel selection menu
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
'//// SCRIPT © REUTLINGER | WWW.PARIS-STUDIOS.DE ///////////////////////////////////////////////////////////////////////////////////////////////////////
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Option Explicit
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Dim ENV_SLOTS As Long
Dim SLIDE_LEFT_POS As Long
Dim SLIDE_TOP_POS As Long
Dim SELECT_SLIDE_ARRAY
Dim SELECT_SLIDE_ARRAY_MAX As Long
Dim ARROW_SELECT As String
Dim I_SELECT As Integer
Dim COLOR_HOVER_ITEM_FONT As String
Dim COLOR_HOVER_ITEM_BACK As String
Dim COLOR_DEFAULT_ITEM_FONT As String
Dim COLOR_SEARCH_FIELD_FONT As String
Dim COLOR_HEADER_LINE_BACK As String
Dim COLOR_SMILEY_BACK As String
Dim COLOR_SLIDER_DEFAULT_BACK As String
Dim COLOR_SLIDERAERA_DEFAULT_BACK As String
Dim COLOR_SLIDER_HOVER_BACK As String
Dim COLOR_SLIDERAERA_HOVER_BACK As String
Dim COLOR_COUNTER_FONT As String
Dim COLOR_PLACEHOLDER_FONT As String
Dim COLOR_SLIDERAERA_PLACEHOLDER_BACK As String
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub UserForm_Activate()
Me.ScrollTop = 700
Call INIT_STAGE
Me.ScrollTop = 0
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub SETUP_SELECT_COLORS()
COLOR_HOVER_ITEM_FONT = &HFFFFFF
COLOR_HOVER_ITEM_BACK = &HB09784
COLOR_DEFAULT_ITEM_FONT = &H2C0D00
COLOR_SEARCH_FIELD_FONT = &H2C0D00
COLOR_PLACEHOLDER_FONT = &H968372
COLOR_HEADER_LINE_BACK = &HF5F50A
COLOR_SMILEY_BACK = &H2C0D00
COLOR_SLIDER_DEFAULT_BACK = &HF5F50A
COLOR_SLIDERAERA_DEFAULT_BACK = &HEBE5E0
COLOR_SLIDER_HOVER_BACK = &H6C5212
COLOR_SLIDERAERA_HOVER_BACK = &H6C5212
COLOR_COUNTER_FONT = &H968372
COLOR_SLIDERAERA_PLACEHOLDER_BACK = &HF9F7F5
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub INIT_STAGE()
Call SETUP_SELECT_COLORS
SMILEY.Visible = False
ENV_SLOTS = 8
I_SELECT = 0
Call RESET_STAGE
SEARCH_FIELD.ForeColor = COLOR_SEARCH_FIELD_FONT
HEADER_LINE.BackColor = COLOR_HEADER_LINE_BACK
SMILEY.ForeColor = COLOR_SMILEY_BACK
SEARCH_FIELD_PLACEHOLDER.ForeColor = COLOR_PLACEHOLDER_FONT
COUNTER.ForeColor = COLOR_COUNTER_FONT
SLIDE_AREA_PLACEHOLDER.BackColor = COLOR_SLIDERAERA_PLACEHOLDER_BACK
Dim I As Long
For I = 1 To ENV_SLOTS
Controls("HOVER_" & I).BorderStyle = fmBorderStyleNone
Next I
SEARCH_FIELD.Text = ""
SEARCH_FIELD.SetFocus
Call HYPER_SEARCH(SEARCH_FIELD.Text)
Call REFRESH_SLIDE(0)
SLIDER.TOP = SLIDE_AREA.TOP
Call SLIDER_RESET(Me.SLIDE_AREA, Me.SLIDER)
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub HOVERME(ByVal ITEM As Long)
Controls("BACK_" & ITEM).BackColor = COLOR_HOVER_ITEM_BACK
Controls("BACK_" & ITEM).Visible = True
Controls("ITEM_" & ITEM).ForeColor = COLOR_HOVER_ITEM_FONT
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call RESET_STAGE
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub SEARCH_FIELD_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If KeyCode = 40 Then SELECT_DOWN
If KeyCode = 38 Then SELECT_UP
If KeyCode = 13 Then
SELECT_NAME = ARROW_SELECT
Unload Me
End If
If KeyCode = 27 Then
SELECT_NAME = ""
Unload Me
End If
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub SELECT_DOWN()
If Me.Controls("ITEM_" & 1).Visible = False Then Exit Sub
If I_SELECT <> ENV_SLOTS Then
I_SELECT = I_SELECT + 1
Call RESET_STAGE
If Me.Controls("ITEM_" & I_SELECT).Visible = False Then I_SELECT = I_SELECT - 1
Call HOVERME(I_SELECT)
ARROW_SELECT = Me.Controls("ITEM_" & I_SELECT).ControlTipText
End If
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub SELECT_UP()
If Me.Controls("ITEM_" & 1).Visible = False Then Exit Sub
If I_SELECT >= 2 Then
I_SELECT = I_SELECT - 1
Call RESET_STAGE
Call HOVERME(I_SELECT)
ARROW_SELECT = Me.Controls("ITEM_" & I_SELECT).ControlTipText
End If
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub SEARCH_FIELD_Change()
SEARCH_FIELD.Text = Replace(SEARCH_FIELD.Text, " ", "*")
If SEARCH_FIELD.Text = "" Then
SEARCH_FIELD_PLACEHOLDER.Text = "Suche"
Else
SEARCH_FIELD_PLACEHOLDER.Text = ""
End If
Call HYPER_SEARCH(SEARCH_FIELD.Text)
Call REFRESH_SLIDE(0)
SLIDER.TOP = SLIDE_AREA.TOP
Call RESET_STAGE
ARROW_SELECT = ""
I_SELECT = 0
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = 0 Then SELECT_NAME = ""
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub RESET_STAGE()
Dim I As Long
Call SLIDER_RESET(Me.SLIDE_AREA, Me.SLIDER)
For I = 1 To ENV_SLOTS
Controls("BACK_" & I).Visible = False
Controls("ITEM_" & I).ForeColor = COLOR_DEFAULT_ITEM_FONT
Next I
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub HOVER_1_Click()
SELECT_NAME = ITEM_1.ControlTipText
Unload Me
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub HOVER_2_Click()
SELECT_NAME = ITEM_2.ControlTipText
Unload Me
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub HOVER_3_Click()
SELECT_NAME = ITEM_3.ControlTipText
Unload Me
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub HOVER_4_Click()
SELECT_NAME = ITEM_4.ControlTipText
Unload Me
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub HOVER_5_Click()
SELECT_NAME = ITEM_5.ControlTipText
Unload Me
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub HOVER_6_Click()
SELECT_NAME = ITEM_6.ControlTipText
Unload Me
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub HOVER_7_Click()
SELECT_NAME = ITEM_7.ControlTipText
Unload Me
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub HOVER_8_Click()
SELECT_NAME = ITEM_8.ControlTipText
Unload Me
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub HOVER_1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call RESET_STAGE
Call HOVERME(1)
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub HOVER_2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call RESET_STAGE
Call HOVERME(2)
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub HOVER_3_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call RESET_STAGE
Call HOVERME(3)
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub HOVER_4_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call RESET_STAGE
Call HOVERME(4)
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub HOVER_5_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call RESET_STAGE
Call HOVERME(5)
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub HOVER_6_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call RESET_STAGE
Call HOVERME(6)
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub HOVER_7_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call RESET_STAGE
Call HOVERME(7)
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub HOVER_8_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call RESET_STAGE
Call HOVERME(8)
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Public Sub SLIDE_AREA_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call SLIDE_AREA_MOUSE_MOVE(Me.SLIDE_AREA, Me.SLIDER)
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub SLIDER_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dim SCROLL_POS As Long
SCROLL_POS = Round((((SELECT_SLIDE_ARRAY_MAX - ENV_SLOTS) * CONTROL_SLIDER(Me.SLIDER, Me.SLIDE_AREA, X, Y, Button)) / 100), 0)
Call REFRESH_SLIDE(SCROLL_POS)
Call SLIDER_MOUSE_MOVE(Me.SLIDE_AREA, Me.SLIDER)
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub SLIDE_AREA_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dim SCROLL_POS As Long
SCROLL_POS = Round((((SELECT_SLIDE_ARRAY_MAX - ENV_SLOTS) * CONTROL_SLIDE_AREA(Me.SLIDER, Me.SLIDE_AREA, X, Y)) / 100), 0)
Call REFRESH_SLIDE(SCROLL_POS)
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub SLIDER_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If Button = 1 Then SLIDE_LEFT_POS = X
If Button = 1 Then SLIDE_TOP_POS = Y
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub REFRESH_SLIDE(ByVal SCROLL_POS As Long)
Dim I As Long
Me.COUNTER.Caption = SELECT_SLIDE_ARRAY_MAX
If SELECT_SLIDE_ARRAY_MAX = 0 Then
SMILEY.Visible = True
Else
SMILEY.Visible = False
End If
For I = 1 To ENV_SLOTS 'MAX_ITEMS
If I <= SELECT_SLIDE_ARRAY_MAX Then
If SELECT_SLIDE_ARRAY(SCROLL_POS + I, 1) <> "" Then
Controls("HOVER_" & I).Visible = True
Controls("ITEM_" & I).Caption = SELECT_SLIDE_ARRAY(SCROLL_POS + I, 1)
Controls("ITEM_" & I).ControlTipText = SELECT_SLIDE_ARRAY(SCROLL_POS + I, 1)
Controls("ITEM_" & I).Visible = True
Else
'Controls("SLOT_" & I).Visible = True
Controls("HOVER_" & I).Visible = False
Controls("ITEM_" & I).Visible = False
End If
Else
Controls("HOVER_" & I).Visible = False
Controls("ITEM_" & I).Visible = False
End If
Next I
If SELECT_SLIDE_ARRAY_MAX < ENV_SLOTS Then
SLIDER.Visible = False
SLIDE_AREA.Visible = False
Else
SLIDER.Visible = True
SLIDE_AREA.Visible = True
End If
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Function CONTROL_SLIDER(ByRef SLIDER As Object, ByRef SLIDE_AREA As Object, ByVal X As Single, ByVal Y As Single, ByVal BUTTON_HOLD As Integer) As Long
'On Error Resume Next
Dim SNG_LEFT As Single
Dim SNG_TOP As Single
Dim SCROLL_POS As Single
Dim SCROLL_RANGE As Single
If BUTTON_HOLD = 1 Then
'//// LEFT AREA
SNG_LEFT = (SLIDER.LEFT + X) - SLIDE_LEFT_POS
If SNG_LEFT < SLIDE_AREA.LEFT Then SNG_LEFT = SLIDE_AREA.LEFT
If (SNG_LEFT + SLIDER.Width) > (SLIDE_AREA.LEFT + SLIDE_AREA.Width) Then
SNG_LEFT = SLIDE_AREA.LEFT + SLIDE_AREA.Width - SLIDER.Width
End If
'//// HEIGHT AREA
SNG_TOP = (SLIDER.TOP + Y) - SLIDE_TOP_POS
If SNG_TOP < SLIDE_AREA.TOP Then SNG_TOP = SLIDE_AREA.TOP
If (SNG_TOP + SLIDER.Height) > (SLIDE_AREA.TOP + SLIDE_AREA.Height) Then
SNG_TOP = SLIDE_AREA.TOP + SLIDE_AREA.Height - SLIDER.Height
End If
SLIDER.Move SNG_LEFT, SNG_TOP
End If
'//// SLIDE RANGE
SCROLL_POS = Round(SLIDER.TOP - SLIDE_AREA.TOP, 0)
SCROLL_RANGE = SLIDE_AREA.Height - SLIDER.Height
CONTROL_SLIDER = Round(((100 * SCROLL_POS) / SCROLL_RANGE), 0) 'PERCENT
End Function
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Function CONTROL_SLIDE_AREA(ByRef SLIDER As Object, ByRef SLIDE_AREA As Object, ByVal X As Single, ByVal Y As Single) As Long
'On Error Resume Next
Dim SNG_LEFT As Single
Dim SNG_TOP As Single
Dim SCROLL_POS As Single
Dim SCROLL_RANGE As Single
Dim SET_POS As Long
SET_POS = Y - SLIDER.Height + SLIDE_AREA.TOP
If SET_POS < SLIDE_AREA.TOP Then
SLIDER.TOP = SLIDE_AREA.TOP
Else
SLIDER.TOP = SET_POS
End If
If ((SLIDE_AREA.TOP + SLIDE_AREA.Height) - (SLIDER.TOP + SLIDER.Height)) < 30 Then
SLIDER.TOP = (SLIDE_AREA.TOP + SLIDE_AREA.Height) - SLIDER.Height
End If
'//// SLIDE RANGE
SCROLL_POS = Round(SLIDER.TOP - SLIDE_AREA.TOP, 0)
SCROLL_RANGE = SLIDE_AREA.Height - SLIDER.Height
CONTROL_SLIDE_AREA = Round(((100 * SCROLL_POS) / SCROLL_RANGE), 0) 'PERCENT
End Function
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub SLIDE_AREA_MOUSE_MOVE(ByVal SLIDE_AREA_ITEM As Object, ByVal SLIDER_ITEM As Object)
SLIDE_AREA_ITEM.BackColor = COLOR_SLIDERAERA_HOVER_BACK
SLIDER_ITEM.BackColor = COLOR_SLIDER_DEFAULT_BACK
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub SLIDER_MOUSE_MOVE(ByVal SLIDE_AREA_ITEM As Object, ByVal SLIDER_ITEM As Object)
SLIDE_AREA_ITEM.BackColor = COLOR_SLIDERAERA_DEFAULT_BACK
SLIDER_ITEM.BackColor = COLOR_SLIDER_HOVER_BACK
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub SLIDER_RESET(ByVal SLIDE_AREA_ITEM As Object, ByVal SLIDER_ITEM As Object)
SLIDE_AREA_ITEM.BackColor = COLOR_SLIDERAERA_DEFAULT_BACK
SLIDER_ITEM.BackColor = COLOR_SLIDER_DEFAULT_BACK
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub HYPER_SEARCH(ByVal SEARCHTEXT As String)
Dim I As Long
Dim S As Long
Dim R As Long
Dim X As Long
Dim FUSION_STRING As String
Dim HYPER_SEARCH(99) As String
Dim HYPER_SEARCH_MAX As Long
Dim SPLIT_CACHE
Dim CONVERSION_CHECK As Boolean
Erase HYPER_SEARCH
CONVERSION_CHECK = False
'//// CREATE HYPERSEARCH ARRAY
If InStr(SEARCHTEXT, "*") <> 0 Then
SPLIT_CACHE = Split(SEARCHTEXT, "*")
For R = 0 To UBound(SPLIT_CACHE)
HYPER_SEARCH(R + 1) = SPLIT_CACHE(R)
HYPER_SEARCH_MAX = R + 1
Next R
Else
HYPER_SEARCH(1) = SEARCHTEXT
HYPER_SEARCH_MAX = 1
End If
'//// CREATE HYPERSEARCH ARRAY
S = 0
If UBound(SELECT_ARRAY) < 6 Then
ReDim SELECT_SLIDE_ARRAY(6, 1)
Else
ReDim SELECT_SLIDE_ARRAY(UBound(SELECT_ARRAY), 1)
End If
For I = 1 To UBound(SELECT_ARRAY)
If SELECT_ARRAY(I, 1) <> "" Then
FUSION_STRING = ""
FUSION_STRING = FUSION_STRING & SELECT_ARRAY(I, 1) & "|"
For R = 1 To HYPER_SEARCH_MAX
If InStr(LCase(FUSION_STRING), LCase(HYPER_SEARCH(R))) <> 0 Then
CONVERSION_CHECK = True
Else
CONVERSION_CHECK = False
Exit For
End If
Next R
If CONVERSION_CHECK = True Then
S = S + 1
For X = 1 To UBound(SELECT_ARRAY, 2)
SELECT_SLIDE_ARRAY(S, X) = SELECT_ARRAY(I, X)
Next X
End If
End If
Next I
SELECT_SLIDE_ARRAY_MAX = S
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
'//// SCRIPT © REUTLINGER | WWW.PARIS-STUDIOS.DE ///////////////////////////////////////////////////////////////////////////////////////////////////////
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
BORDERLESS VBA USERFORM
WM API AERO SOFT SHADOW SIMULATION
Rahmenlose Excel VBA Userform GUI incl. Windows Aero Frame und weichen Schatten ( GPU-beschleunigt ) DWMAPI.DLL [ Windows 7/8/10 x86 ]
Frameless/Borderless Excel VBA Userform GUI incl. Windows Aero frame and soft shadows ( GPU accelerated ) dwmapi.dll [ Windows 7/8/10 x86 ]
Rahmenlose Excel VBA Userform GUI incl. Windows Aero Frame und weichen Schatten ( GPU-beschleunigt ) DWMAPI.DLL [ Windows 7/8/10 x86 ]
Frameless/Borderless Excel VBA Userform GUI incl. Windows Aero frame and soft shadows ( GPU accelerated ) dwmapi.dll [ Windows 7/8/10 x86 ]
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
'//// SCRIPT © WWW.PARIS-STUDIOS.DE @ REUTLINGER ///////////////////////////////////////////////////////////////////////////////////////////////////////
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
'//// VBA DWM API AERO SOFT SHADOW SIMULATION
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Option Explicit
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As Long
Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal H_WINDOW As Long, ByVal lngWinIdx As Long, ByVal dwNewLong As Long) As Long
Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal H_WINDOW As Long, ByVal lngWinIdx As Long) As Long
Private Declare PtrSafe Function SetLayeredWindowAttributes Lib "user32" (ByVal H_WINDOW As Long, ByVal crKey As Integer, ByVal bAlpha As Integer, ByVal dwFlags As Long) As Long
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal H_WINDOW As Long) As Long
Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal H_WINDOW As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare PtrSafe Function ReleaseCapture Lib "user32" () As Long
Private Declare PtrSafe Function SetWindowRgn Lib "user32" (ByVal H_WINDOW As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare PtrSafe Function ScreenToClient Lib "user32" (ByVal H_WINDOW As Long, lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function GetWindow Lib "user32" (ByVal hWnd As Long, ByVal wCmd As Long) As Long
Private Declare PtrSafe Function DwmSetWindowAttribute Lib "dwmapi" (ByVal hWnd As Long, ByVal attr As Integer, ByRef attrValue As Integer, ByVal attrSize As Integer) As Long
Private Declare PtrSafe Function DwmExtendFrameIntoClientArea Lib "dwmapi" (ByVal hWnd As Long, ByRef NEWMARGINS As MARGINS) As Long
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Type POINTAPI
X As Long
Y As Long
End Type
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Const GWL_STYLE = (-16)
Private Const WS_CAPTION = &HC00000 '//// WS_BORDER Or WS_DLGFRAME
Private Const WS_BORDER = &H800000
Private Const GWL_EXSTYLE As Long = (-20) '//// OFFSET OF WINDOW EXTENDED STYLE
Private Const WS_EX_DLGMODALFRAME As Long = &H1 '//// CONTROLS IF WINDOW HAS AN ICON
Private Const SC_CLOSE As Long = &HF060
Private Const SW_SHOW As Long = 5
Private Const WS_EX_LAYERED = &H80000
Private Const LWA_COLORKEY = &H1
Private Const LWA_ALPHA = &H2
Private Const WS_EX_TRANSPARENT = &H20&
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Enum ESetWindowPosStyles
SWP_SHOWWINDOW = &H40
SWP_HIDEWINDOW = &H80
SWP_FRAMECHANGED = &H20 '//// FRAME CHANGED SEND WM_NCCALCSIZE
SWP_NOACTIVATE = &H10
SWP_NOCOPYBITS = &H100
SWP_NOMOVE = &H2
SWP_NOOWNERZORDER = &H200 '// DONT DO OWNER Z ORDERING
SWP_NOREDRAW = &H8
SWP_NOREPOSITION = SWP_NOOWNERZORDER
SWP_NOSIZE = &H1
SWP_NOZORDER = &H4
SWP_DRAWFRAME = SWP_FRAMECHANGED
HWND_NOTOPMOST = -2
End Enum
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Type MARGINS
leftWidth As Long
rightWidth As Long
topHeight As Long
bottomHeight As Long
End Type
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Const HTCAPTION = 2
Private XWNDFORM, XWNDFORMEX As Long
Private Const WM_NCLBUTTONDOWN = &HA1
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub UserForm_Activate()
Dim ISTYLE, HWNDFORM As Long
Dim btrans As Byte
btrans = 128
Dim NEWMARGINS As MARGINS
HWNDFORM = FindWindow(vbNullString, Me.Caption) '//// GET WINDOW
ISTYLE = GetWindowLong(HWNDFORM, GWL_STYLE) '//// BASIC WINDOW STYLE FLAGS FOR THE FORM
ISTYLE = ISTYLE And Not WS_CAPTION '//// NO CAPTION AREA
SetWindowLong HWNDFORM, GWL_STYLE, ISTYLE '//// SET BASIC WINDOW STYLES
ISTYLE = GetWindowLong(HWNDFORM, GWL_EXSTYLE) '//// BUILD EXTENDED WINDOW STYLE
ISTYLE = ISTYLE And Not WS_EX_DLGMODALFRAME '//// NO BORDER
'ISTYLE = ISTYLE Or WS_EX_LAYERED '//// ADD ONE COLOR TRANSPARENCE
'ISTYLE = ISTYLE Or WS_EX_TRANSPARENT '//// ADD SEMI-TRANSPARENT WINDOW
SetWindowLong HWNDFORM, GWL_EXSTYLE, ISTYLE
'SetLayeredWindowAttributes HWNDFORM, vbCyan, BTRANS, LWA_ALPHA '//// SEMI TRANSPARENT WINDOW
'SetLayeredWindowAttributes HWNDFORM, vbCyan, BTRANS, LWA_COLORKEY '//// COLOR SCREEN TRNSPARENCY
XWNDFORM = FindWindow("ThunderDFrame", vbNullString) '//// GET NEW WINDOW
DwmSetWindowAttribute XWNDFORM, 2, 2, 4 '//// DWMAPI
With NEWMARGINS
.rightWidth = 1 '//// -1
.leftWidth = 1 '//// -1
.topHeight = 1 '//// -1
.bottomHeight = 1 '//// -1
End With
DwmExtendFrameIntoClientArea XWNDFORM, NEWMARGINS '//// DWMAPI
DrawMenuBar HWNDFORM '//// CLEAN MENU BAR
Me.Width = Me.Width - 5 '//// FRAMECUT BALANCE OFFSET
Me.Height = Me.Height - 23 '//// FRAMECUT BALANCE OFFSET
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub CMD_CLOSE_Click()
Unload Me
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If Button = 1 Then
ReleaseCapture
SendMessage XWNDFORM, WM_NCLBUTTONDOWN, HTCAPTION, 0&
End If
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub LINK_URL_Click()
Dim internet
Set internet = CreateObject("InternetExplorer.Application")
internet.Visible = True
internet.Navigate ("http://www.paris-studios.de")
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
'//// SCRIPT © WWW.PARIS-STUDIOS.DE @ REUTLINGER ///////////////////////////////////////////////////////////////////////////////////////////////////////
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
EXCEL NEW INSTANCE LAUNCHER
STANDALONE EXE
Mit dem [EXCEL_NEW_INSTANCE_LAUNCHER.exe] Excel Workbooks/Dateien als neue separate Single (Standalone) Instanz öffnen, ermöglicht paralleles arbeiten mit VBA UserForms. Zudem wird das Excel Splash Screen ausgeblendet/deaktiviert
With the [EXCEL_NEW_INSTANCE_LAUNCHER.exe] Excel Workbooks / Open Files as a new separate single (Standalone) instance, you can work in parallel with VBA UserForms. In addition, the Excel Splash Screen is hidden / deactivated
-ICQ 
VBA.EXCEL 16X CORE MULTI-THREADED MULTICORE
PROCESSING ARCHITECTURE SOLUTION ENGINE
Standard gem. werden alle Excel VBA Scripte auf dem primären CPU/Kern ausgeführt ( bei 4 CPU Kerne = 25% Problem ). Das Script präsentiert eine Lösung alle 1x - 16x CPU Kerne nativ ohne Third-Party Add-Ons gleichzeitig und simultan zu nutzen um intensive Berechnungen zu parallelisieren und die 100% maximale CPU Leistung der Computers zu nutzen. [ Windows 7/8/10 x86 ]Mehr als 1400 % Leistungssteigerung von 1 zu 8 CPU Kerne
Standard acc. All Excel VBA scripts are run on the primary core / CPU ( @ 4 CPU Cores = 25% Problem ). The script presents a solution to simultaneously use all 1x - 16x CPU cores native without Third-Party Add-Ons to parallelize intensive calculations and to use the 100% maximum CPU performance of the computers. [ Windows 7/8/10 x86 ] More than 1400% increase in performance from 1 to 8 cpu cores
VBA.EXCEL PHOTO IMAGE RESIZE CROP ASSISTENT ENGINE
LIKE PHOTOSHOP
Effektiv Fotos bearbeiten, schneiden, skalieren via Excel VBA mit 3 vordefinierten Maskierungsrahmen [ Windows 7/8/10 x86 ]
Effectively edit, crop and scale using Excel VBA with 3 predefined masking frames
FIRST Download & Install third party service provider @ ImageMagick ImageMagick-7.0.5-7-Q16-x86-dll.exe
'//// SOMETHING CODE ;)
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
'//// SCRIPT © REUTLINGER / WWW.PARIS-STUDIOS.DE - ALL RIGHTS RESERVED /////////////////////////////////////////////////////////////////////////////////
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Option Explicit
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Declare Function GetActiveWindow Lib "user32" () As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal H_WINDOW As Long, ByVal lngWinIdx As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal H_WINDOW As Long, ByVal lngWinIdx As Long) As Long
Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal H_WINDOW As Long, ByVal crKey As Integer, ByVal bAlpha As Integer, ByVal dwFlags As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private 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
Private Declare Function DrawMenuBar Lib "user32" (ByVal H_WINDOW As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal H_WINDOW 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 SetWindowRgn Lib "user32" (ByVal H_WINDOW As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function ScreenToClient Lib "user32" (ByVal H_WINDOW As Long, lpPoint As POINTAPI) As Long
Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (p As tCursor) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function DwmSetWindowAttribute Lib "dwmapi" (ByVal hwnd As Long, ByVal attr As Integer, ByRef attrValue As Integer, ByVal attrSize As Integer) As Long
Private Declare Function DwmExtendFrameIntoClientArea Lib "dwmapi" (ByVal hwnd As Long, ByRef NEWMARGINS As MARGINS) As Long
Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Type BITMAP
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Dim M_SNG_LEFT_POS As Long
Dim M_SNG_TOP_POS As Long
Dim Z_SNG_LEFT_POS As Long
Dim Z_SNG_TOP_POS As Long
Dim SAVE_AREA As Boolean
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Type POINTAPI
X As Long
Y As Long
End Type
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Type tCursor
LEFT As Long
TOP As Long
End Type
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Const GWL_STYLE = (-16)
Private Const WS_CAPTION = &HC00000 '//// WS_BORDER Or WS_DLGFRAME
Private Const WS_BORDER = &H800000
Private Const GWL_EXSTYLE As Long = (-20) '//// OFFSET OF WINDOW EXTENDED STYLE
Private Const WS_EX_DLGMODALFRAME As Long = &H1 '//// CONTROLS IF WINDOW HAS AN ICON
Private Const SC_CLOSE As Long = &HF060
Private Const SW_SHOW As Long = 5
Private Const WS_EX_LAYERED = &H80000
Private Const LWA_COLORKEY = &H1
Private Const LWA_ALPHA = &H2
Private Const WS_EX_TRANSPARENT = &H20&
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Enum ESetWindowPosStyles
SWP_SHOWWINDOW = &H40
SWP_HIDEWINDOW = &H80
SWP_FRAMECHANGED = &H20 '//// FRAME CHANGED SEND WM_NCCALCSIZE
SWP_NOACTIVATE = &H10
SWP_NOCOPYBITS = &H100
SWP_NOMOVE = &H2
SWP_NOOWNERZORDER = &H200 '// DONT DO OWNER Z ORDERING
SWP_NOREDRAW = &H8
SWP_NOREPOSITION = SWP_NOOWNERZORDER
SWP_NOSIZE = &H1
SWP_NOZORDER = &H4
SWP_DRAWFRAME = SWP_FRAMECHANGED
HWND_NOTOPMOST = -2
End Enum
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Type MARGINS
leftWidth As Long
rightWidth As Long
topHeight As Long
bottomHeight As Long
End Type
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Const HTCAPTION = 2
Private XWNDFORM, XWNDFORMEX As Long
Private Const WM_NCLBUTTONDOWN = &HA1
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Dim mPos As tCursor
Dim hdc As Long
Dim pointsPerPixelX, pointsPerPixelY As Double
Dim WhereIsTheMouseAt As tCursor
Dim convertMouseToForm As tCursor
Dim FIRST_RUN As Boolean
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Const LOGPIXELSX = 88
Const LOGPIXELSY = 90
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub UserForm_Initialize()
Dim ISTYLE, HWNDFORM As Long
Dim btrans As Byte
btrans = 128
Dim NEWMARGINS As MARGINS
HWNDFORM = FindWindow(vbNullString, Me.Caption) '//// GET WINDOW
ISTYLE = GetWindowLong(HWNDFORM, GWL_STYLE) '//// BASIC WINDOW STYLE FLAGS FOR THE FORM
ISTYLE = ISTYLE And Not WS_CAPTION '//// NO CAPTION AREA
SetWindowLong HWNDFORM, GWL_STYLE, ISTYLE '//// SET BASIC WINDOW STYLES
ISTYLE = GetWindowLong(HWNDFORM, GWL_EXSTYLE) '//// BUILD EXTENDED WINDOW STYLE
ISTYLE = ISTYLE And Not WS_EX_DLGMODALFRAME '//// NO BORDER
'ISTYLE = ISTYLE Or WS_EX_LAYERED '//// ADD ONE COLOR TRANSPARENCE
'ISTYLE = ISTYLE Or WS_EX_TRANSPARENT '//// ADD SEMI-TRANSPARENT WINDOW
SetWindowLong HWNDFORM, GWL_EXSTYLE, ISTYLE
'SetLayeredWindowAttributes HWNDFORM, vbCyan, btrans, LWA_ALPHA '//// SEMI TRANSPARENT WINDOW
'SetLayeredWindowAttributes HWNDFORM, vbCyan, btrans, LWA_COLORKEY '//// COLOR SCREEN TRNSPARENCY
XWNDFORM = FindWindow("ThunderDFrame", vbNullString) '//// GET NEW WINDOW
DwmSetWindowAttribute XWNDFORM, 2, 2, 4 '//// DWMAPI
With NEWMARGINS
.rightWidth = 1 '//// -1
.leftWidth = 1 '//// -1
.topHeight = 1 '//// -1
.bottomHeight = 1 '//// -1
End With
DwmExtendFrameIntoClientArea XWNDFORM, NEWMARGINS '//// DWMAPI
DrawMenuBar HWNDFORM '//// CLEAN MENU BAR
Me.Height = 500
Me.Width = Me.Width - 5 '//// FRAMECUT BALANCE OFFSET
Me.Height = Me.Height - 24 '//// FRAMECUT BALANCE OFFSET
' Me.LEFT = GUI_COCKPIT.LEFT + GUI_COCKPIT.Width / 2 - Me.Width / 2
' Me.TOP = GUI_COCKPIT.TOP + GUI_COCKPIT.Height / 2 - Me.Height / 2
LINE_BOTTOM.LEFT = 0
LINE_BOTTOM.TOP = Me.Height - 3
LINE_BOTTOM.Width = Me.Width
LINE_BOTTOM.Height = 3
LINE_TOP.TOP = 1
LINE_TOP.LEFT = 0
LINE_TOP.Width = Me.Width
LINE_TOP.Height = 3
MAIN_IMG.Visible = False
FIRST_RUN = True
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub UserForm_Activate()
If FIRST_RUN = True Then
MAIN_IMG.Visible = False
'Call INIT_STAGE
Dim SELECT_LOGO As String
SELECT_LOGO = GET_FILE_JPG
ENV_IMAGE_ASSISTENT_IMPORT_FILE = SELECT_LOGO
ENV_IMAGE_ASSISTENT_EXPORT_FILE = Mid(ENV_IMAGE_ASSISTENT_IMPORT_FILE, 1, Len(ENV_IMAGE_ASSISTENT_IMPORT_FILE) - 4) & "_CROP.jpg"
If SELECT_LOGO <> "" Then Call INIT_STAGE
Call SET_START_MASK
FIRST_RUN = False
End If
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub INIT_STAGE()
MASK_IMG.Width = 240
MASK_IMG.Height = 136
Call SET_MASK_AREA
L_TITEL.LEFT = MASK_IMG.LEFT - 6
L_TITEL.TOP = MASK_IMG.TOP - 16
L_TITEL.Caption = "IMAGE CROP 16:9"
MAIN_IMG.Visible = False
ZOOM_ITEM.Visible = False
Call RESET_STAGE
Call IMAGE_LOADER
Call SET_MASK_AREA
Call SET_ASPECT_RATIO_H
Call SET_CENTER_Y
Call SET_CENTER_X
Call SET_ZOOM_FACTOR
Call CHECK_SAVE_STATUS
MAIN_IMG.Visible = True
ZOOM_ITEM.Visible = True
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Public Sub SET_START_MASK()
' MASK_IMG.Width = 240
' MASK_IMG.Height = 136
'
ENV_IMAGE_ASSISTENT_FORMAT(1) = 240
ENV_IMAGE_ASSISTENT_FORMAT(2) = 240
Call SET_MASK_AREA
L_TITEL.LEFT = MASK_IMG.LEFT - 6
L_TITEL.TOP = MASK_IMG.TOP - 16
L_TITEL.Caption = "IMAGE CROP 16:9"
'Call RESET_STAGE
'Call IMAGE_LOADER
Call SET_MASK_AREA
Call SET_ASPECT_RATIO_H
Call SET_CENTER_Y
Call SET_CENTER_X
'Call SET_ZOOM_FACTOR
Call CHECK_SAVE_STATUS
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub CMD_CLOSE_Click()
Unload Me
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub Userform_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If Button = 1 Then
ReleaseCapture
SendMessage XWNDFORM, WM_NCLBUTTONDOWN, HTCAPTION, 0&
End If
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub CMD_MASK_169_Click()
MASK_IMG.Width = 240
MASK_IMG.Height = 136
ENV_IMAGE_ASSISTENT_FORMAT(1) = MASK_IMG.Width
ENV_IMAGE_ASSISTENT_FORMAT(2) = MASK_IMG.Height
Call SET_MASK_AREA
L_TITEL.LEFT = MASK_IMG.LEFT - 6
L_TITEL.TOP = MASK_IMG.TOP - 16
L_TITEL.Caption = "IMAGE CROP 16:9"
'Call RESET_STAGE
'Call IMAGE_LOADER
Call SET_MASK_AREA
Call SET_ASPECT_RATIO_H
Call SET_CENTER_Y
Call SET_CENTER_X
'Call SET_ZOOM_FACTOR
Call CHECK_SAVE_STATUS
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub CMD_MASK_43_Click()
MASK_IMG.Width = 240
MASK_IMG.Height = 180
ENV_IMAGE_ASSISTENT_FORMAT(1) = MASK_IMG.Width '4:3
ENV_IMAGE_ASSISTENT_FORMAT(2) = MASK_IMG.Height '4:3
Call SET_MASK_AREA
L_TITEL.LEFT = MASK_IMG.LEFT - 6
L_TITEL.TOP = MASK_IMG.TOP - 16
L_TITEL.Caption = "IMAGE CROP 16:9"
Call SET_MASK_AREA
L_TITEL.LEFT = MASK_IMG.LEFT - 6
L_TITEL.TOP = MASK_IMG.TOP - 16
L_TITEL.Caption = "IMAGE CROP 4:3"
'Call RESET_STAGE
'Call IMAGE_LOADER
Call SET_MASK_AREA
Call SET_ASPECT_RATIO_H
Call SET_CENTER_Y
Call SET_CENTER_X
'Call SET_ZOOM_FACTOR
Call CHECK_SAVE_STATUS
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub CMD_MASK_A4_Click()
MASK_IMG.Width = 210
MASK_IMG.Height = 297
ENV_IMAGE_ASSISTENT_FORMAT(1) = MASK_IMG.Width
ENV_IMAGE_ASSISTENT_FORMAT(2) = MASK_IMG.Height
Call SET_MASK_AREA
L_TITEL.LEFT = MASK_IMG.LEFT - 6
L_TITEL.TOP = MASK_IMG.TOP - 16
L_TITEL.Caption = "IMAGE CROP A4 5:7"
'Call RESET_STAGE
'Call IMAGE_LOADER
Call SET_MASK_AREA
Call SET_ASPECT_RATIO_H
Call SET_CENTER_Y
Call SET_CENTER_X
'Call SET_ZOOM_FACTOR
Call CHECK_SAVE_STATUS
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub CMD_ZOOM_IN_Click()
Dim C_ZOOM_H As Long
Dim C_ZOOM_W As Long
If MAIN_IMG.Width < (Me.IMPORT_W.Caption - 10) Then
MAIN_IMG.Width = MAIN_IMG.Width + 10
Call SET_ASPECT_RATIO_H
Call SET_ZOOM_FACTOR
Call CHECK_SAVE_STATUS
End If
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub CMD_ZOOM_OUT_Click()
If MAIN_IMG.Width > 20 Then
MAIN_IMG.Width = MAIN_IMG.Width - 10
Call SET_ASPECT_RATIO_H
Call SET_ZOOM_FACTOR
Call CHECK_SAVE_STATUS
End If
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub CMD_LC_Click()
MAIN_IMG.LEFT = MASK_IMG.LEFT
MAIN_IMG.TOP = Round(SLIDE_AREA.TOP + (SLIDE_AREA.Height / 2) - (MAIN_IMG.Height / 2), 0)
Call CHECK_SAVE_STATUS
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub CMD_RC_Click()
MAIN_IMG.LEFT = (MASK_IMG.LEFT) - ((MASK_IMG.LEFT + MAIN_IMG.Width) - (MASK_IMG.LEFT + MASK_IMG.Width))
MAIN_IMG.TOP = Round(SLIDE_AREA.TOP + (SLIDE_AREA.Height / 2) - (MAIN_IMG.Height / 2), 0)
Call CHECK_SAVE_STATUS
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub CMD_TC_Click()
MAIN_IMG.LEFT = Round(SLIDE_AREA.LEFT + (SLIDE_AREA.Width / 2) - (MAIN_IMG.Width / 2), 0)
MAIN_IMG.TOP = MASK_IMG.TOP
Call CHECK_SAVE_STATUS
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub CMD_BC_Click()
MAIN_IMG.LEFT = Round(SLIDE_AREA.LEFT + (SLIDE_AREA.Width / 2) - (MAIN_IMG.Width / 2), 0)
MAIN_IMG.TOP = (MASK_IMG.TOP) - ((MASK_IMG.TOP + MAIN_IMG.Height) - (MASK_IMG.TOP + MASK_IMG.Height))
Call CHECK_SAVE_STATUS
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub CMD_LT_Click()
MAIN_IMG.LEFT = MASK_IMG.LEFT
MAIN_IMG.TOP = MASK_IMG.TOP
Call CHECK_SAVE_STATUS
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub CMD_RT_Click()
MAIN_IMG.LEFT = (MASK_IMG.LEFT) - ((MASK_IMG.LEFT + MAIN_IMG.Width) - (MASK_IMG.LEFT + MASK_IMG.Width))
MAIN_IMG.TOP = MASK_IMG.TOP
Call CHECK_SAVE_STATUS
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub CMD_LB_Click()
MAIN_IMG.LEFT = MASK_IMG.LEFT
MAIN_IMG.TOP = (MASK_IMG.TOP) - ((MASK_IMG.TOP + MAIN_IMG.Height) - (MASK_IMG.TOP + MASK_IMG.Height))
Call CHECK_SAVE_STATUS
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub CMD_RB_Click()
MAIN_IMG.LEFT = (MASK_IMG.LEFT) - ((MASK_IMG.LEFT + MAIN_IMG.Width) - (MASK_IMG.LEFT + MASK_IMG.Width))
MAIN_IMG.TOP = (MASK_IMG.TOP) - ((MASK_IMG.TOP + MAIN_IMG.Height) - (MASK_IMG.TOP + MASK_IMG.Height))
Call CHECK_SAVE_STATUS
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub CMD_CENTER_Y_Click()
Call SET_CENTER_Y
Call CHECK_SAVE_STATUS
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub CMD_CENTER_X_Click()
Call SET_CENTER_X
Call CHECK_SAVE_STATUS
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub CMD_CENTER_XY_Click()
Call SET_CENTER_X
Call SET_CENTER_Y
Call CHECK_SAVE_STATUS
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub CMD_FIT_Y_Click()
Call SET_FIT_Y
Call SET_ASPECT_RATIO_W
Call SET_CENTER_Y
Call SET_CENTER_X
Call CHECK_SAVE_STATUS
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub CMD_FIT_X_Click()
Call SET_FIT_X
Call SET_ASPECT_RATIO_H
Call SET_CENTER_X
Call SET_CENTER_Y
Call CHECK_SAVE_STATUS
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub CMD_OPEN_CLICK()
Dim SELECT_LOGO As String
SELECT_LOGO = GET_FILE_JPG
ENV_IMAGE_ASSISTENT_IMPORT_FILE = SELECT_LOGO
ENV_IMAGE_ASSISTENT_EXPORT_FILE = Mid(ENV_IMAGE_ASSISTENT_IMPORT_FILE, 1, Len(ENV_IMAGE_ASSISTENT_IMPORT_FILE) - 4) & "_CROP.jpg"
If SELECT_LOGO <> "" Then Call INIT_STAGE
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Function GET_FILE_JPG() As String
Dim fldr As FileDialog
Dim strPath As String
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFilePicker)
With fldr
.Filters.Clear
.Filters.Add "JPG-Dateien (*.jpg)", "*.jpg"
.Title = "Select a JPG FIle"
.AllowMultiSelect = False
.InitialFileName = strPath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GET_FILE_JPG = sItem
Set fldr = Nothing
End Function
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Public Sub SET_MASK_AREA()
MASK_IMG.LEFT = Round(SLIDE_AREA.LEFT + (SLIDE_AREA.Width / 2) - (MASK_IMG.Width / 2), 0)
MASK_IMG.TOP = Round(SLIDE_AREA.TOP + (SLIDE_AREA.Height / 2) - (MASK_IMG.Height / 2), 0)
B_TOP.LEFT = MASK_IMG.LEFT - 6
B_TOP.TOP = MASK_IMG.TOP - 6
B_TOP.Width = MASK_IMG.Width + 12
B_TOP.Height = 6
B_LEFT.LEFT = MASK_IMG.LEFT - 6
B_LEFT.TOP = MASK_IMG.TOP
B_LEFT.Width = 6
B_LEFT.Height = MASK_IMG.Height
B_RIGHT.LEFT = MASK_IMG.LEFT + MASK_IMG.Width
B_RIGHT.TOP = MASK_IMG.TOP
B_RIGHT.Width = 6
B_RIGHT.Height = MASK_IMG.Height
B_BOTTOM.LEFT = MASK_IMG.LEFT - 6
B_BOTTOM.TOP = MASK_IMG.TOP + MASK_IMG.Height
B_BOTTOM.Width = MASK_IMG.Width + 12
B_BOTTOM.Height = 6
MASK_IMG_FRAME.LEFT = MASK_IMG.LEFT
MASK_IMG_FRAME.TOP = MASK_IMG.TOP
MASK_IMG_FRAME.Width = MASK_IMG.Width
MASK_IMG_FRAME.Height = MASK_IMG.Height
SLIDE_AREA.Visible = False
L_TITEL.LEFT = MASK_IMG.LEFT - 6
L_TITEL.TOP = MASK_IMG.TOP - 16
L_TITEL.Caption = "IMAGE CROP " & ENV_IMAGE_ASSISTENT_FORMAT(1) & "x" & ENV_IMAGE_ASSISTENT_FORMAT(2) & " | " & Me.IMPORT_W.Caption & "x" & Me.IMPORT_H.Caption & " (" & ENV_IMAGE_ASSISTENT_CROP_SIZE(5) & "px)"
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Public Sub IMAGE_LOADER()
MAIN_IMG.LEFT = SLIDE_AREA.LEFT
MAIN_IMG.TOP = SLIDE_AREA.TOP
MAIN_IMG.Visible = False
MAIN_IMG.Picture = Nothing
MAIN_IMG.Picture = LoadPicture("")
MAIN_IMG.Visible = False
MAIN_IMG.Picture = Nothing
MAIN_IMG.Picture = LoadPicture(ENV_IMAGE_ASSISTENT_IMPORT_FILE, , , Color)
MAIN_IMG.Visible = True
Call GET_EXIF(ENV_IMAGE_ASSISTENT_IMPORT_FILE)
Application.Wait (Now + TimeValue("0:00:01"))
MAIN_IMG.Width = 400
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Public Sub GET_EXIF(ByVal MYIMAGE As String)
Dim objPic As IPictureDisp
Dim udtBMP As BITMAP
Set objPic = LoadPicture(MYIMAGE)
GetObjectAPI objPic.Handle, Len(udtBMP), udtBMP
Me.IMPORT_W.Caption = udtBMP.bmWidth
Me.IMPORT_H.Caption = udtBMP.bmHeight
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Public Sub SET_FIT_Y()
MAIN_IMG.Height = MASK_IMG.Height
If MAIN_IMG.Width < MASK_IMG.Width Then
MAIN_IMG.Width = MASK_IMG.Width
Call SET_ASPECT_RATIO_H
End If
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Public Sub SET_FIT_X()
MAIN_IMG.Width = MASK_IMG.Width
If MAIN_IMG.Height < MASK_IMG.Height Then
MAIN_IMG.Height = MASK_IMG.Height
Call SET_ASPECT_RATIO_W
End If
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Public Sub SET_ASPECT_RATIO_H()
MAIN_IMG.Height = Round(((MAIN_IMG.Width * Me.IMPORT_H.Caption) / Me.IMPORT_W.Caption), 0)
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Public Sub SET_ASPECT_RATIO_W()
MAIN_IMG.Width = Round(((MAIN_IMG.Height * Me.IMPORT_W.Caption) / Me.IMPORT_H.Caption), 0)
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Public Sub SET_CENTER_Y()
MAIN_IMG.TOP = Round(SLIDE_AREA.TOP + (SLIDE_AREA.Height / 2) - (MAIN_IMG.Height / 2), 0)
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Public Sub SET_CENTER_X()
MAIN_IMG.LEFT = Round(SLIDE_AREA.LEFT + (SLIDE_AREA.Width / 2) - (MAIN_IMG.Width / 2), 0)
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Public Sub SET_ZOOM_FACTOR()
ZOOM_FACTOR.Caption = Round(((100 * MAIN_IMG.Width) / Me.IMPORT_W.Caption), 1)
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Public Sub CMD_SAVE_Click()
CMD_SAVE.Visible = False
BACK_SAVE.Visible = False
LOCK_PLANE.Visible = True
LOCK_PLANE.LEFT = -20
LOCK_PLANE.TOP = -20
LOCK_PLANE.Width = Me.Width + 100
LOCK_PLANE.Height = Me.Height + 100
STANDBY_ICON.Visible = False
STANDBY_ICON.LEFT = (Me.Width / 2) - (STANDBY_ICON.Width / 2)
STANDBY_ICON.TOP = (Me.Height / 2) - (STANDBY_ICON.Height / 2)
'Call START_LOADING_CIRCLE(Me)
STANDBY_ICON.Visible = True
Call SET_COORDINATES
Call CROP_RESIZE_IMAGE_IMAGEMAGICK_ENGINE
LOCK_PLANE.Visible = False
STANDBY_ICON.Visible = False
Call SPLASH_FORM
'Unload Me
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub CMD_SAVE_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
'CMD_SAVE.ForeColor = ENV_COLOR_WHITE
BACK_SAVE.BackStyle = fmBackStyleOpaque
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Public Sub SET_COORDINATES()
'//// MASK SIZE RELATION
L_MASK_W_GUI.Caption = WorksheetFunction.RoundUp(((MASK_IMG.Width * 100) / (MAIN_IMG.Width)), 1)
L_MASK_H_GUI.Caption = WorksheetFunction.RoundUp(((MASK_IMG.Height * 100) / (MAIN_IMG.Height)), 1)
L_MASK_W_EXPORT.Caption = WorksheetFunction.RoundUp(((Me.IMPORT_W.Caption * L_MASK_W_GUI.Caption) / 100), 1)
L_MASK_H_EXPORT.Caption = WorksheetFunction.RoundUp(((Me.IMPORT_H.Caption * L_MASK_H_GUI.Caption) / 100), 1)
'//// MASK OFFSET RELATION
L_MASK_OFFSET_L_GUI.Caption = WorksheetFunction.RoundUp((MASK_IMG.LEFT - MAIN_IMG.LEFT), 1)
L_MASK_OFFSET_T_GUI.Caption = WorksheetFunction.RoundUp((MASK_IMG.TOP - MAIN_IMG.TOP), 1)
ZOOM_FACTOR.Caption = WorksheetFunction.RoundUp(((100 * MAIN_IMG.Width) / Me.IMPORT_W.Caption), 1)
L_MASK_OFFSET_L_EXPORT.Caption = Replace(WorksheetFunction.RoundUp((L_MASK_OFFSET_L_GUI.Caption * 100) / (ZOOM_FACTOR.Caption), 1), "-", "")
L_MASK_OFFSET_T_EXPORT.Caption = Replace(WorksheetFunction.RoundUp((L_MASK_OFFSET_T_GUI.Caption * 100) / (ZOOM_FACTOR.Caption), 1), "-", "")
ENV_IMAGE_ASSISTENT_CROP_SIZE(1) = L_MASK_W_EXPORT.Caption
ENV_IMAGE_ASSISTENT_CROP_SIZE(2) = L_MASK_H_EXPORT.Caption
ENV_IMAGE_ASSISTENT_CROP_SIZE(3) = L_MASK_OFFSET_L_EXPORT.Caption
ENV_IMAGE_ASSISTENT_CROP_SIZE(4) = L_MASK_OFFSET_T_EXPORT.Caption
If ENV_IMAGE_ASSISTENT_CROP_SIZE(5) = 0 Then ENV_IMAGE_ASSISTENT_CROP_SIZE(5) = IMPORT_W.Caption 'ORIGINAL SIZE
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub SPLASH_FORM()
ENV_ACTIVE_GUI_SETUP(0) = ENV_COLOR_LIME_DARK
ENV_ACTIVE_GUI_SETUP(1) = GUI_IMAGE_ASSISTENT.LEFT
ENV_ACTIVE_GUI_SETUP(2) = GUI_IMAGE_ASSISTENT.TOP
ENV_ACTIVE_GUI_SETUP(3) = GUI_IMAGE_ASSISTENT.Width
ENV_ACTIVE_GUI_SETUP(4) = GUI_IMAGE_ASSISTENT.Height
GUI_SPLASH_FX.Show
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Public Sub CHECK_SAVE_STATUS()
CMD_SAVE.ForeColor = ENV_COLOR_TITAN
L_INFO.ForeColor = ENV_COLOR_TITAN
CMD_MASK_43.ForeColor = ENV_COLOR_TITAN
CMD_MASK_169.ForeColor = ENV_COLOR_TITAN
CMD_MASK_A4.ForeColor = ENV_COLOR_TITAN
L_MAINTITEL.ForeColor = ENV_COLOR_TITAN
CMD_CLOSE.ForeColor = ENV_COLOR_TITAN
CMD_PARISB.ForeColor = ENV_COLOR_TITAN
If MAIN_IMG.TOP < (LINE_0.TOP - 30) Then
CMD_MASK_43.ForeColor = ENV_COLOR_WHITE
CMD_MASK_169.ForeColor = ENV_COLOR_WHITE
CMD_MASK_A4.ForeColor = ENV_COLOR_WHITE
L_MAINTITEL.ForeColor = ENV_COLOR_WHITE
End If
If MAIN_IMG.TOP < (LINE_0.TOP - 40) Then
CMD_CLOSE.ForeColor = ENV_COLOR_WHITE
End If
If MAIN_IMG.LEFT + MAIN_IMG.Width > CMD_SAVE.LEFT + CMD_SAVE.Width - 5 Then CMD_SAVE.ForeColor = ENV_COLOR_WHITE
If MAIN_IMG.LEFT + MAIN_IMG.Width > L_INFO.LEFT + L_INFO.Width - 5 Then L_INFO.ForeColor = ENV_COLOR_WHITE
SAVE_AREA = False
B_TOP.BackColor = ENV_COLOR_MAGENTA
B_LEFT.BackColor = ENV_COLOR_MAGENTA
B_RIGHT.BackColor = ENV_COLOR_MAGENTA
B_BOTTOM.BackColor = ENV_COLOR_MAGENTA
CMD_SAVE.Visible = False
BACK_SAVE.Visible = False
L_TITEL.ForeColor = &H8D7467
If MAIN_IMG.TOP < (MASK_IMG.TOP - 14) Then L_TITEL.ForeColor = &HFFFFFF
If MAIN_IMG.Width < MASK_IMG.Width Then Exit Sub
If MAIN_IMG.Height < MASK_IMG.Height Then Exit Sub
If MAIN_IMG.Width + MAIN_IMG.LEFT < MASK_IMG.Width + MASK_IMG.LEFT Then Exit Sub
If MAIN_IMG.Height + MAIN_IMG.TOP < MASK_IMG.Height + MASK_IMG.TOP Then Exit Sub
If MAIN_IMG.LEFT > MASK_IMG.LEFT Then Exit Sub
If MAIN_IMG.TOP > MASK_IMG.TOP Then Exit Sub
B_TOP.BackColor = ENV_COLOR_LIME_DARK
B_LEFT.BackColor = ENV_COLOR_LIME_DARK
B_RIGHT.BackColor = ENV_COLOR_LIME_DARK
B_BOTTOM.BackColor = ENV_COLOR_LIME_DARK
SAVE_AREA = True
CMD_SAVE.Visible = True
BACK_SAVE.Visible = True
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Public Sub MAIN_IMG_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If Button = 1 Then
M_SNG_LEFT_POS = X
M_SNG_TOP_POS = Y
End If
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Public Sub MAIN_IMG_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dim SNG_LEFT As Single
Dim SNG_TOP As Single
ZOOM_ITEM.BackColor = ENV_COLOR_LIME
If Button = 1 Then
With MAIN_IMG
'//// LEFT AREA
SNG_LEFT = (.LEFT + X) - M_SNG_LEFT_POS
'//// LOCK AREA
'If SNG_LEFT < SLIDE_AREA.LEFT Then SNG_LEFT = SLIDE_AREA.LEFT
'If (SNG_LEFT + .Width) > (SLIDE_AREA.LEFT + SLIDE_AREA.Width) Then SNG_LEFT = SLIDE_AREA.LEFT + SLIDE_AREA.Width - .Width
'//// LOCK AREA
'//// HEIGHT AREA
SNG_TOP = (.TOP + Y) - M_SNG_TOP_POS
'//// LOCK AREA
'If SNG_TOP < SLIDE_AREA.TOP Then SNG_TOP = SLIDE_AREA.TOP
'If (SNG_TOP + .Height) > (SLIDE_AREA.TOP + SLIDE_AREA.Height) Then SNG_TOP = SLIDE_AREA.TOP + SLIDE_AREA.Height - .Height
'//// LOCK AREA
.Move SNG_LEFT, SNG_TOP
End With
End If
Call RESET_STAGE
Call CHECK_SAVE_STATUS
Call SET_COORDINATES
Call SET_SCALE_ICON
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub SET_SCALE_ICON()
ZOOM_ITEM.LEFT = MAIN_IMG.LEFT + MAIN_IMG.Width - 24
ZOOM_ITEM.TOP = MAIN_IMG.TOP + MAIN_IMG.Height - 24
ZOOM_ITEM_W.LEFT = MAIN_IMG.LEFT + MAIN_IMG.Width - 28
ZOOM_ITEM_W.TOP = MAIN_IMG.TOP + MAIN_IMG.Height - 28
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Public Sub ZOOM_ITEM_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If Button = 1 Then
Z_SNG_LEFT_POS = X
Z_SNG_TOP_POS = Y
End If
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Public Sub ZOOM_ITEM_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dim SNG_LEFT As Single
Dim SNG_TOP As Single
ZOOM_ITEM.BackColor = ENV_COLOR_MAGENTA
If Button = 1 Then
With ZOOM_ITEM
'//// LEFT AREA
SNG_LEFT = (.LEFT + X) - Z_SNG_LEFT_POS
'//// LOCK AREA
'If SNG_LEFT < SLIDE_AREA.LEFT Then SNG_LEFT = SLIDE_AREA.LEFT
'If (SNG_LEFT + .Width) > (SLIDE_AREA.LEFT + SLIDE_AREA.Width) Then SNG_LEFT = SLIDE_AREA.LEFT + SLIDE_AREA.Width - .Width
'//// LOCK AREA
'//// HEIGHT AREA
SNG_TOP = (.TOP + Y) - Z_SNG_TOP_POS
'//// LOCK AREA
'If SNG_TOP < SLIDE_AREA.TOP Then SNG_TOP = SLIDE_AREA.TOP
'If (SNG_TOP + .Height) > (SLIDE_AREA.TOP + SLIDE_AREA.Height) Then SNG_TOP = SLIDE_AREA.TOP + SLIDE_AREA.Height - .Height
'//// LOCK AREA
.Move SNG_LEFT, SNG_TOP
End With
MAIN_IMG.Width = ZOOM_ITEM.LEFT - MAIN_IMG.LEFT + ZOOM_ITEM.Width
MAIN_IMG.Height = Round(((MAIN_IMG.Width * Me.IMPORT_H.Caption) / Me.IMPORT_W.Caption), 0)
ZOOM_ITEM_W.LEFT = MAIN_IMG.LEFT + MAIN_IMG.Width - 28
ZOOM_ITEM_W.TOP = MAIN_IMG.TOP + MAIN_IMG.Height - 28
End If
Call CHECK_SAVE_STATUS
Call SET_COORDINATES
Call SET_SCALE_ICON
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub CMD_ZOOM_IN_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
L_INFO.Caption = "ZOOM IN"
Call SET_SCALE_ICON
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub CMD_ZOOM_OUT_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
L_INFO.Caption = "ZOOM OUT"
Call SET_SCALE_ICON
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub CMD_CENTER_Y_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
L_INFO.Caption = "Y CENTER"
Call SET_SCALE_ICON
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub CMD_CENTER_X_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
L_INFO.Caption = "X CENTER"
Call SET_SCALE_ICON
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub CMD_CENTER_XY_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
L_INFO.Caption = "X&Y CENTER"
Call SET_SCALE_ICON
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub CMD_FIT_Y_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
L_INFO.Caption = "Y FIT"
Call SET_SCALE_ICON
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub CMD_FIT_X_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
L_INFO.Caption = "X FIT"
Call SET_SCALE_ICON
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub CMD_TC_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
L_INFO.Caption = "TOP CENTER"
Call SET_SCALE_ICON
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub CMD_RC_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
L_INFO.Caption = "RIGHT CENTER"
Call SET_SCALE_ICON
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub CMD_BC_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
L_INFO.Caption = "BOTTOM CENTER"
Call SET_SCALE_ICON
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub CMD_LC_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
L_INFO.Caption = "LEFT CENTER"
Call SET_SCALE_ICON
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub CMD_LT_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
L_INFO.Caption = "LEFT TOP"
Call SET_SCALE_ICON
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub CMD_RT_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
L_INFO.Caption = "RIGHT TOP"
Call SET_SCALE_ICON
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub CMD_LB_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
L_INFO.Caption = "LEFT BOTTOM"
Call SET_SCALE_ICON
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub CMD_RB_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
L_INFO.Caption = "RIGHT BOTTOM"
Call SET_SCALE_ICON
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub CMD_OPEN_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
L_INFO.Caption = "OPEN IMAGE FILE"
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call RESET_STAGE
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub RESET_STAGE()
BACK_SAVE.BackStyle = fmBackStyleTransparent
CMD_SAVE.ForeColor = ENV_COLOR_TITAN
L_INFO.Caption = ""
ZOOM_ITEM.BackColor = ENV_COLOR_LIME_DARK
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
'//// SCRIPT © REUTLINGER / WWW.PARIS-STUDIOS.DE - ALL RIGHTS RESERVED /////////////////////////////////////////////////////////////////////////////////
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
'//// SCRIPT © REUTLINGER / WWW.PARIS-STUDIOS.DE - ALL RIGHTS RESERVED /////////////////////////////////////////////////////////////////////////////////
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Public Function CROP_RESIZE_IMAGE_IMAGEMAGICK_ENGINE() As String
Dim CMD_CACHE As String
Dim TEMP_IMAGE As String
Dim EXPORT_THUMB_IMAGE As String
Dim objStream
TEMP_IMAGE = "C:\temp\imagecropcache.jpg"
EXPORT_THUMB_IMAGE = Mid(ENV_IMAGE_ASSISTENT_EXPORT_FILE, 1, Len(ENV_IMAGE_ASSISTENT_EXPORT_FILE) - 4) & "_P.JPG"
On Error Resume Next
Kill ENV_IMAGE_ASSISTENT_EXPORT_FILE
On Error GoTo 0
On Error Resume Next
Kill TEMP_IMAGE
On Error GoTo 0
On Error Resume Next
Kill EXPORT_THUMB_IMAGE
On Error GoTo 0
FileCopy ENV_IMAGE_ASSISTENT_IMPORT_FILE, TEMP_IMAGE
'Call TRY_FILE_CHECK(TEMP_IMAGE)
'/
'//
'///
'////
CMD_CACHE = CMD_CACHE & "chcp 65001" & vbCrLf
CMD_CACHE = CMD_CACHE & "CD " & ENV_ROOT_FOLDER & "ROOT\SERVICES\" & vbCrLf
CMD_CACHE = CMD_CACHE & Mid(ENV_ROOT_FOLDER, 1, 2) & vbCrLf
'CROP
CMD_CACHE = CMD_CACHE & "magick.exe " & Chr(34) & TEMP_IMAGE & Chr(34) & " -crop " & ENV_IMAGE_ASSISTENT_CROP_SIZE(1) & "x" & ENV_IMAGE_ASSISTENT_CROP_SIZE(2) & "+" & ENV_IMAGE_ASSISTENT_CROP_SIZE(3) & "+" & ENV_IMAGE_ASSISTENT_CROP_SIZE(4) & " " & Chr(34) & ENV_IMAGE_ASSISTENT_EXPORT_FILE & Chr(34) & vbCrLf
CMD_CACHE = CMD_CACHE & "timeout /T 1 /nobreak" & vbCrLf
'RESIZE
CMD_CACHE = CMD_CACHE & "magick.exe convert -scale " & ENV_IMAGE_ASSISTENT_CROP_SIZE(5) & " " & Chr(34) & ENV_IMAGE_ASSISTENT_EXPORT_FILE & Chr(34) & " " & Chr(34) & ENV_IMAGE_ASSISTENT_EXPORT_FILE & Chr(34) & vbCrLf
'RESIZE THUMB
CMD_CACHE = CMD_CACHE & "magick.exe convert -scale " & ENV_IMAGE_ASSISTENT_CROP_SIZE(6) & " " & Chr(34) & ENV_IMAGE_ASSISTENT_EXPORT_FILE & Chr(34) & " " & Chr(34) & EXPORT_THUMB_IMAGE & Chr(34) & vbCrLf
'////
'///
'//
'/
'/
'//
'///
'////
Set objStream = CreateObject("ADODB.Stream")
objStream.Charset = "utf-8" '"ascii" '"utf-8" '"ascii""
objStream.Open
objStream.WriteText CMD_CACHE '//// WRITE STREAM
objStream.SaveToFile ENV_ROOT_FOLDER & "ROOT\SERVICES\CROPIMAGE.CMD", 2 ' 1 Default, creates a new file 2 Completely overwrite data in an existing file
objStream.Close
Set objStream = Nothing
'////
'///
'//
'/
'Call TRY_FILE_CHECK(ENV_ROOT_FOLDER & "ROOT\SERVICES\CROPIMAGE.CMD")
Dim X
RUNFILE = (ENV_ROOT_FOLDER & "ROOT\SERVICES\CROPIMAGE.CMD")
X = Shell(RUNFILE, vbMinimizeocus)
'Call TRY_FILE_CHECK(ENV_IMAGE_ASSISTENT_EXPORT_FILE)
'Call TRY_FILE_CHECK(EXPORT_THUMB_IMAGE)
End Function
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
'Usage: convert [options ...] file [ [options ...] file ...] [options ...] file
'///// -adjoin join images into a single multi-image file
'///// -affine matrix affine transform matrix
'///// -annotate geometry text annotate the image with text
'///// -antialias remove pixel-aliasing
'///// -append append an image sequence
'///// -authenticate value decrypt image with this password
'///// -average average an image sequence
'///// -background color background color
'///// -bias value add bias when convolving an image
'///// -black-threshold value forces all pixels below the threshold into black
'///// -blue-primary point chromaticity blue primary point
'///// -blur geometry blur the image
'///// -border geometry surround image with a border of color
'///// -bordercolor color border color
'///// -channel type apply option to select image channels
'///// -charcoal radius simulate a charcoal drawing
'///// -chop geometry remove pixels from the image interior
'///// -clip clip along the first path from the 8BIM profile
'///// -clip-path id clip along a named path from the 8BIM profile
'///// -clone index clone an image
'///// -coalesce merge a sequence of images
'///// -colorize value colorize the image with the fill color
'///// -colors value preferred number of colors in the image
'///// -colorspace type alternate image colorspace
'///// -combine combine a sequence of images
'///// -comment string annotate image with comment
'///// -compose operator set image composite operator
'///// -composite composite image
'///// -compress type type of pixel compression when writing the image
'///// -contrast enhance or reduce the image contrast
'///// -convolve coefficients apply a convolution kernel to the image
'///// -crop geometry cut out a rectangular region of the image
'///// -cycle amount cycle the image colormap
'///// -debug events display copious debugging information
'///// -define format:option define one or more image format options
'///// -deconstruct break down an image sequence into constituent parts
'///// -delay value display the next image after pausing
'///// -delete index delete the image from the image sequence
'///// -density geometry horizontal and vertical density of the image
'///// -depth value image depth
'///// -despeckle reduce the speckles within an image
'///// -display server get image or font from this X server
'///// -dispose method GIF disposal method
'///// -dither apply Floyd/Steinberg error diffusion to image
'///// -draw string annotate the image with a graphic primitive
'///// -edge radius apply a filter to detect edges in the image
'///// -emboss radius emboss an image
'///// -encoding type text encoding type
'///// -endian type endianness (MSB or LSB) of the image
'///// -enhance apply a digital filter to enhance a noisy image
'///// -equalize perform histogram equalization to an image
'///// -evaluate operator value evaluate an arithmetic, relational, or logical expression
'///// -extent geometry set the image size
'///// -extract geometry extract area from image
'///// -family name render text with this font family
'///// -fill color color to use when filling a graphic primitive
'///// -filter type use this filter when resizing an image
'///// -flatten flatten a sequence of images
'///// -flip flip image in the vertical direction
'///// -floodfill geometry color floodfill the image with color
'///// -flop flop image in the horizontal direction
'///// -font name render text with this font
'///// -format "string" output formatted image characteristics
'///// -frame geometry surround image with an ornamental border
'///// -fuzz distance colors within this distance are considered equal
'///// -fx expression apply mathematical expression to an image channel(s)
'///// -gamma value level of gamma correction
'///// -gaussian geometry gaussian blur an image
'///// -geometry geometry perferred size or location of the image
'///// -green-primary point chromaticity green primary point
'///// -gravity type horizontal and vertical text placement
'///// -help print program options
'///// -identify identify the format and characteristics of the image
'///// -implode amount implode image pixels about the center
'///// -insert index insert last image into the image sequence
'///// -intent type type of rendering intent when managing the image color
'///// -interlace type type of image interlacing scheme
'///// -label name assign a label to an image
'///// -lat geometry local adaptive thresholding
'///// -level value adjust the level of image contrast
'///// -limit type value pixel cache resource limit
'///// -log format format of debugging information
'///// -loop iterations add Netscape loop extension to your GIF animation
'///// -map filename transform image colors to match this set of colors
'///// -mask filename set the image clip mask
'///// -matte store matte channel if the image has one
'///// -mattecolor color frame color
'///// -median radius apply a median filter to the image
'///// -modulate value vary the brightness, saturation, and hue
'///// -monitor monitor progress
'///// -monochrome transform image to black and white
'///// -morph value morph an image sequence
'///// -mosaic create a mosaic from an image sequence
'///// -motion-blur geometry simulate motion blur
'///// -negate replace every pixel with its complementary color
'///// -noise radius add or reduce noise in an image
'///// -normalize transform image to span the full range of colors
'///// -opaque color change this color to the fill color
'///// -ordered-dither NxN ordered dither the image
'///// -orient type image orientation
'///// -page geometry size and location of an image canvas (setting)
'///// -paint radius simulate an oil painting
'///// -ping efficiently determine image attributes
'///// -pointsize value font point size
'///// -posterize levels reduce the image to a limited number of color levels
'///// -preview type image preview type
'///// -profile filename add, delete, or apply an image profile
'///// -quality value JPEG/MIFF/PNG compression level
'///// -quiet suppress all error or warning messages
'///// -radial-blur angle radial blur the image
'///// -raise value lighten/darken image edges to create a 3-D effect
'///// -random-threshold low,high random threshold the image
'///// -region geometry apply options to a portion of the image
'///// -raise value lighten/darken image edges to create a 3-D effect
'///// -red-primary point chromaticity red primary point
'///// -render render vector graphics
'///// -repage geometry size and location of an image canvas
'///// -resample geometry change the resolution of an image
'///// -resize geometry resize the image
'///// -roll geometry roll an image vertically or horizontally
'///// -rotate degrees apply Paeth rotation to the image
'///// -sample geometry scale image with pixel sampling
'///// -sampling-factor geometry horizontal and vertical sampling factor
'///// -scale geometry scale the image
'///// -scene value image scene number
'///// -seed value pseudo-random number generator seed value
'///// -segment values segment an image
'///// -separate separate an image channel into a grayscale image
'///// -sepia-tone threshold simulate a sepia-toned photo
'///// -set attribute value set an image attribute
'///// -shade degrees shade the image using a distant light source
'///// -shadow geometry simulate an image shadow
'///// -sharpen geometry sharpen the image
'///// -shave geometry shave pixels from the image edges
'///// -shear geometry slide one edge of the image along the X or Y axis
'///// -sigmodial-contrast geometry lightness rescaling using sigmoidal contrast enhancement
'///// -size geometry width and height of image
'///// -solarize threshold negate all pixels above the threshold level
'///// -splice geometry splice the background color into the image
'///// -spread amount displace image pixels by a random amount
'///// -strip strip image of all profiles and comments
'///// -stroke color graphic primitive stroke color
'///// -strokewidth value graphic primitive stroke width
'///// -stretch type render text with this font stretch
'///// -style type render text with this font style
'///// -support factor resize support: > 1.0 is blurry, < 1.0 is sharp
'///// -swap indexes swap two images in the image sequence
'///// -swirl degrees swirl image pixels about the center
'///// -texture filename name of texture to tile onto the image background
'///// -threshold value threshold the image
'///// -thumbnail geometry create a thumbnail of the image
'///// -tile filename tile image when filling a graphic primitive
'///// -tint value tint the image with the fill color
'///// -transform affine transform image
'///// -transparent color make this color transparent within the image
'///// -treedepth value color tree depth
'///// -trim trim image edges
'///// -type type image type
'///// -undercolor color annotation bounding box color
'///// -units type the units of image resolution
'///// -unsharp geometry sharpen the image
'///// -verbose print detailed information about the image
'///// -version print version information
'///// -view FlashPix viewing transforms
'///// -virtual-pixel method virtual pixel access method
'///// -wave geometry alter an image along a sine wave
'///// -weight type render text with this font weight
'///// -white-point point chromaticity white point
'///// -white-threshold value forces all pixels above the threshold into white
'///// -write filename write images to this file
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
'//// SCRIPT © REUTLINGER / WWW.PARIS-STUDIOS.DE - ALL RIGHTS RESERVED /////////////////////////////////////////////////////////////////////////////////
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
'//// SCRIPT © REUTLINGER / WWW.PARIS-STUDIOS.DE - ALL RIGHTS RESERVED /////////////////////////////////////////////////////////////////////////////////
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Option Explicit
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Public ENV_SOFTWARE_VERSION As String
Public ENV_ROOT_FOLDER As String
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Public ENV_COLOR_LIME As Long
Public ENV_COLOR_LIME_DARK As Long
Public ENV_COLOR_LIGHT As Long
Public ENV_COLOR_TITAN_DARK As Long
Public ENV_COLOR_TITAN As Long
Public ENV_COLOR_WHITE As Long
Public ENV_COLOR_GLASS As Long
Public ENV_COLOR_MAGENTA As Long
Public ENV_ACTIVE_GUI_SETUP(5) As String
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Public ENV_IMAGE_ASSISTENT_IMPORT_FILE As String
Public ENV_IMAGE_ASSISTENT_FORMAT(2) As Long 'MASK FORMAT
Public ENV_IMAGE_ASSISTENT_CROP_SIZE(6) As Long '1=WIDTH, 2=HEIGTH, 3=LEFT, 4=TOP, 5=SIZE 6=SIZETHUMB
Public ENV_IMAGE_ASSISTENT_EXPORT_FILE As String
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Public Sub SET_ENVIRONMENT_PUBLIC_VARIABLE()
ENV_ROOT_FOLDER = Application.ActiveWorkbook.Path & "\"
ENV_COLOR_LIME = &H1FDDB
ENV_COLOR_LIME_DARK = &HDFBE&
ENV_COLOR_LIGHT = &HF8F5F3
ENV_COLOR_GLASS = &HF9F8F7
ENV_COLOR_TITAN = &HAFA096
ENV_COLOR_TITAN_DARK = &H8C8078
ENV_COLOR_WHITE = &HFFFFFF
ENV_COLOR_MAGENTA = &H9900CC
ENV_IMAGE_ASSISTENT_CROP_SIZE(5) = 1080 'IMAGE SIZE
ENV_IMAGE_ASSISTENT_CROP_SIZE(6) = 200 'IMAGE THUMB SIZE
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub START_CROP_ENGINE(control As IRibbonControl)
Call SET_ENVIRONMENT_PUBLIC_VARIABLE
GUI_IMAGE_ASSISTENT.Show
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
'//// SCRIPT © REUTLINGER / WWW.PARIS-STUDIOS.DE - ALL RIGHTS RESERVED /////////////////////////////////////////////////////////////////////////////////
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
VBA DYNAMIC DESIGN RANGE SLIDER
RANGE SLIDER CONTROL
Das Script präsentiert in Excel VBA Userform GUI ein Dynamisches Design Slider Steuerelement, welches zusätzlich die Abtastung an der aktuellen Mausposition verfeinert wenn dies nach unten gezogen wird
The script presented in Excel VBA Userform GUI a dynamic design slider control, which addition refines the sampling at the current mouse position when it is pulled down
'// AREA RANGE SLIDER
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Option Explicit
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As Long
Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal H_WINDOW As Long, ByVal lngWinIdx As Long, ByVal dwNewLong As Long) As Long
Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal H_WINDOW As Long, ByVal lngWinIdx As Long) As Long
Private Declare PtrSafe Function SetLayeredWindowAttributes Lib "user32" (ByVal H_WINDOW As Long, ByVal crKey As Integer, ByVal bAlpha As Integer, ByVal dwFlags As Long) As Long
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal H_WINDOW As Long) As Long
Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal H_WINDOW As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare PtrSafe Function ReleaseCapture Lib "user32" () As Long
Private Declare PtrSafe Function SetWindowRgn Lib "user32" (ByVal H_WINDOW As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare PtrSafe Function ScreenToClient Lib "user32" (ByVal H_WINDOW As Long, lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function GetWindow Lib "user32" (ByVal hWnd As Long, ByVal wCmd As Long) As Long
Private Declare PtrSafe Function GetCursorPos Lib "user32" (p As tCursor) As Long
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal HDC As Long, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function DwmSetWindowAttribute Lib "dwmapi" (ByVal hWnd As Long, ByVal attr As Integer, ByRef attrValue As Integer, ByVal attrSize As Integer) As Long
Private Declare PtrSafe Function DwmExtendFrameIntoClientArea Lib "dwmapi" (ByVal hWnd As Long, ByRef NEWMARGINS As MARGINS) As Long
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Type POINTAPI
X As Long
Y As Long
End Type
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Type tCursor
LEFT As Long
TOP As Long
End Type
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Const GWL_STYLE = (-16)
Private Const WS_CAPTION = &HC00000 '//// WS_BORDER Or WS_DLGFRAME
Private Const WS_BORDER = &H800000
Private Const GWL_EXSTYLE As Long = (-20) '//// OFFSET OF WINDOW EXTENDED STYLE
Private Const WS_EX_DLGMODALFRAME As Long = &H1 '//// CONTROLS IF WINDOW HAS AN ICON
Private Const SC_CLOSE As Long = &HF060
Private Const SW_SHOW As Long = 5
Private Const WS_EX_LAYERED = &H80000
Private Const LWA_COLORKEY = &H1
Private Const LWA_ALPHA = &H2
Private Const WS_EX_TRANSPARENT = &H20&
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Enum ESetWindowPosStyles
SWP_SHOWWINDOW = &H40
SWP_HIDEWINDOW = &H80
SWP_FRAMECHANGED = &H20 '//// FRAME CHANGED SEND WM_NCCALCSIZE
SWP_NOACTIVATE = &H10
SWP_NOCOPYBITS = &H100
SWP_NOMOVE = &H2
SWP_NOOWNERZORDER = &H200 '// DONT DO OWNER Z ORDERING
SWP_NOREDRAW = &H8
SWP_NOREPOSITION = SWP_NOOWNERZORDER
SWP_NOSIZE = &H1
SWP_NOZORDER = &H4
SWP_DRAWFRAME = SWP_FRAMECHANGED
HWND_NOTOPMOST = -2
End Enum
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Type MARGINS
leftWidth As Long
rightWidth As Long
topHeight As Long
bottomHeight As Long
End Type
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Const HTCAPTION = 2
Private XWNDFORM, XWNDFORMEX As Long
Private Const WM_NCLBUTTONDOWN = &HA1
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Const LOGPIXELSX = 88
Const LOGPIXELSY = 90
Dim SLIDE_POS As Long
Dim SLIDE_LOCK As Boolean
Dim M_SNG_LEFT_POS As Long
Dim M_SNG_TOP_POS As Long
Dim CONSOLE_CACHE As String
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If Button = 1 Then
ReleaseCapture
SendMessage XWNDFORM, WM_NCLBUTTONDOWN, HTCAPTION, 0&
End If
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub CMD_CLOSE_Click()
Unload Me
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub SLIDER_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
SLIDER_FINE.Visible = False
FINE_DIRECTION.Visible = False
SLIDE_AREA.Visible = False
FINE_LINE.Visible = False
DYNAMIC_SLIDE_RANGE.Visible = False
SLIDER.ForeColor = &HFFFFFF
SLIDER_B.ForeColor = &HBD02CC
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub UserForm_Initialize()
Dim ISTYLE, HWNDFORM As Long
Dim btrans As Byte
btrans = 128
Dim NEWMARGINS As MARGINS
HWNDFORM = FindWindow(vbNullString, Me.Caption) '//// GET WINDOW
ISTYLE = GetWindowLong(HWNDFORM, GWL_STYLE) '//// BASIC WINDOW STYLE FLAGS FOR THE FORM
ISTYLE = ISTYLE And Not WS_CAPTION '//// NO CAPTION AREA
SetWindowLong HWNDFORM, GWL_STYLE, ISTYLE '//// SET BASIC WINDOW STYLES
ISTYLE = GetWindowLong(HWNDFORM, GWL_EXSTYLE) '//// BUILD EXTENDED WINDOW STYLE
ISTYLE = ISTYLE And Not WS_EX_DLGMODALFRAME '//// NO BORDER
'ISTYLE = ISTYLE Or WS_EX_LAYERED '//// ADD ONE COLOR TRANSPARENCE
'ISTYLE = ISTYLE Or WS_EX_TRANSPARENT '//// ADD SEMI-TRANSPARENT WINDOW
SetWindowLong HWNDFORM, GWL_EXSTYLE, ISTYLE
'SetLayeredWindowAttributes HWNDFORM, vbCyan, btrans, LWA_ALPHA '//// SEMI TRANSPARENT WINDOW
'SetLayeredWindowAttributes HWNDFORM, vbCyan, btrans, LWA_COLORKEY '//// COLOR SCREEN TRNSPARENCY
XWNDFORM = FindWindow("ThunderDFrame", vbNullString) '//// GET NEW WINDOW
DwmSetWindowAttribute XWNDFORM, 2, 2, 4 '//// DWMAPI
With NEWMARGINS
.rightWidth = 1 '//// -1
.leftWidth = 1 '//// -1
.topHeight = 1 '//// -1
.bottomHeight = 1 '//// -1
End With
DwmExtendFrameIntoClientArea XWNDFORM, NEWMARGINS '//// DWMAPI
DrawMenuBar HWNDFORM '//// CLEAN MENU BAR
Me.Width = Me.Width - 5 '//// FRAMECUT BALANCE OFFSET
Me.Height = Me.Height - 24 '//// FRAMECUT BALANCE OFFSET
'//// BORDER LINES
LINE_LEFT.LEFT = 1
LINE_LEFT.TOP = 0
LINE_LEFT.Width = 0.5
LINE_LEFT.Height = Me.Height
LINE_RIGHT.TOP = 0
LINE_RIGHT.LEFT = Me.Width - 1.5
LINE_RIGHT.Width = 0.5 '1.5
LINE_RIGHT.Height = Me.Height
LINE_BOTTOM.LEFT = 0
LINE_BOTTOM.TOP = Me.Height - 1.5
LINE_BOTTOM.Width = Me.Width
LINE_BOTTOM.Height = 0.5
LINE_TOP.TOP = 1
LINE_TOP.LEFT = 0
LINE_TOP.Width = Me.Width
LINE_TOP.Height = 0.5
'//// STARTUP
SLIDE_AREA.Visible = False
SLIDER_FINE.Visible = False
FINE_DIRECTION.Visible = False
FINE_LINE.Width = 1
FINE_LINE.Visible = False
RANGE_LABEL = L_MIN.Text
DYNAMIC_SLIDE_RANGE.Visible = False
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Public Sub SLIDER_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If Button = 1 Then
M_SNG_LEFT_POS = X
M_SNG_TOP_POS = Y
SLIDER.ForeColor = &HBD02CC
SLIDER_B.ForeColor = &HFFFFFF
End If
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Public Sub SLIDER_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dim SNG_LEFT As Long, SNG_TOP As Long, SCROLL_RANGE As Long, SCROLL_POS As Long, SLIDEAERA As Long
Dim F1 As Double, F2 As Double, P2 As Double, P3 As Double, P4 As Double, VALUE_MIN As Double, VALUE_MAX As Double, MULTI As Double, MULTIPLICATOR As Double
Dim DECI As Integer
If Button = 1 Then
With SLIDER
'//// LEFT AREA
SNG_LEFT = (.LEFT + X) - M_SNG_LEFT_POS
If SNG_LEFT < SLIDE_AREA.LEFT Then SNG_LEFT = SLIDE_AREA.LEFT
If (SNG_LEFT + .Width) > (SLIDE_AREA.LEFT + SLIDE_AREA.Width) Then
SNG_LEFT = SLIDE_AREA.LEFT + SLIDE_AREA.Width - .Width
End If
'//// HEIGHT AREA
SNG_TOP = (.TOP + Y) - M_SNG_TOP_POS
If SNG_TOP < SLIDE_AREA.TOP Then SNG_TOP = SLIDE_AREA.TOP
If (SNG_TOP + .Height) > (SLIDE_AREA.TOP + SLIDE_AREA.Height) Then
SNG_TOP = SLIDE_AREA.TOP + SLIDE_AREA.Height - .Height
End If
.Move SNG_LEFT, SNG_TOP
End With
'//// SETTINGS
VALUE_MIN = CDbl(L_MIN.Text)
VALUE_MAX = CDbl(L_MAX.Text)
DECI = 1
MULTI = 1
'//// SETTINGS
SLIDER_FINE.Visible = True
'DYNAMIC_SLIDE_RANGE.Visible = True
SLIDER_B.LEFT = SLIDER.LEFT - 3
SLIDER_FINE.LEFT = SLIDER.LEFT + ((SLIDER.Width - SLIDER_FINE.Width) / 2)
FINE_DIRECTION.LEFT = SLIDER.LEFT
FINE_DIRECTION.TOP = SLIDER.TOP + 22
FINE_LINE.LEFT = Round(SLIDER.LEFT + ((SLIDER.Width) / 2) - 1)
FINE_LINE.TOP = DYNAMIC_SLIDE_RANGE.TOP
FINE_LINE.Height = SLIDER_FINE.TOP - SLIDER.TOP + 2
'//// FINE SLIDER
If (Y) > ((SLIDER.Height / 2)) Then
SLIDER_FINE.TOP = Y + SLIDER.TOP - (SLIDER.Height / 2)
Else
SLIDER_FINE.TOP = SLIDER.TOP
End If
'//// FINE SLIDER
'//// FINE SLIDER MULTIPLICATOR
MULTIPLICATOR = ((Y - (SLIDER.Height / 2)) / MULTI)
If MULTIPLICATOR > 10 Then
FINE_DIRECTION.Visible = False
FINE_LINE.Visible = True
If SLIDE_LOCK = False Then
SLIDE_POS = SLIDER.LEFT
SLIDE_LOCK = True
End If
P2 = Round(100 * ((SLIDE_POS - SLIDE_AREA.LEFT)) / (SLIDE_AREA.Width - SLIDER.Width)) 'SLIDER POS %
DYNAMIC_SLIDE_RANGE.Width = Round(SLIDE_AREA.Width * MULTIPLICATOR) 'SET WIDTH
P3 = Round((DYNAMIC_SLIDE_RANGE.Width - (SLIDE_AREA.Width)) * (P2) / 100) 'QUOTA % MORE THEN SLIDE_AREA.WIDTH
DYNAMIC_SLIDE_RANGE.LEFT = Round(SLIDE_AREA.LEFT - P3)
'//// SECOND VISUAL SLIDE LINE ONLY FOR NICE EFFECT
DYNAMIC_SLIDE_RANGE_VISUAL.Width = Round(SLIDE_AREA.Width * MULTIPLICATOR / 50) 'SET WIDTH
P4 = Round((DYNAMIC_SLIDE_RANGE_VISUAL.Width - (SLIDE_AREA.Width)) * (P2) / 100)
DYNAMIC_SLIDE_RANGE_VISUAL.LEFT = Round(SLIDE_AREA.LEFT - P4)
'//// SECOND VISUAL SLIDE LINE ONLY FOR NICE EFFECT
Else
FINE_DIRECTION.Visible = True
FINE_LINE.Visible = False
DYNAMIC_SLIDE_RANGE.Width = SLIDE_AREA.Width
DYNAMIC_SLIDE_RANGE.LEFT = SLIDE_AREA.LEFT
SLIDE_LOCK = False
End If
'//// FINE SLIDER MULTIPLICATOR
'//// SLIDE CALC
SLIDEAERA = DYNAMIC_SLIDE_RANGE.Width - SLIDER.Width
F1 = (SLIDEAERA / (VALUE_MAX - VALUE_MIN)) 'OVERSAMPLING
F2 = (((SLIDER.LEFT - DYNAMIC_SLIDE_RANGE.LEFT) / F1) + VALUE_MIN) 'CONVERSION
'//// SLIDE CALC
RANGE_LABEL = Round(F2, DECI) '//// PUBLISH VALUE
End If
CONSOLE.Text = ""
CONSOLE_CACHE = "// CONSOLE"
CONSOLE_CACHE = CONSOLE_CACHE & CONSOLE_SLASH(CONSOLE_CACHE)
CONSOLE.Text = CONSOLE.Text & CONSOLE_CACHE & vbCrLf
CONSOLE_CACHE = Round(MULTIPLICATOR, 2) & " MULTIPLICATOR"
CONSOLE_CACHE = CONSOLE_CACHE & CONSOLE_SLASH(CONSOLE_CACHE)
CONSOLE.Text = CONSOLE.Text & CONSOLE_CACHE & vbCrLf
CONSOLE_CACHE = DYNAMIC_SLIDE_RANGE.Width & " DYNAMIC_SLIDE_RANGE.Width"
CONSOLE_CACHE = CONSOLE_CACHE & CONSOLE_SLASH(CONSOLE_CACHE)
CONSOLE.Text = CONSOLE.Text & CONSOLE_CACHE & vbCrLf
CONSOLE_CACHE = P2 & " % SLIDER POS"
CONSOLE_CACHE = CONSOLE_CACHE & CONSOLE_SLASH(CONSOLE_CACHE)
CONSOLE.Text = CONSOLE.Text & CONSOLE_CACHE & vbCrLf
CONSOLE_CACHE = P3 & " % QUOTA MORE"
CONSOLE_CACHE = CONSOLE_CACHE & CONSOLE_SLASH(CONSOLE_CACHE)
CONSOLE.Text = CONSOLE.Text & CONSOLE_CACHE & vbCrLf
CONSOLE_CACHE = DYNAMIC_SLIDE_RANGE.LEFT & " DYNAMIC_SLIDE_RANGE.LEFT"
CONSOLE_CACHE = CONSOLE_CACHE & CONSOLE_SLASH(CONSOLE_CACHE)
CONSOLE.Text = CONSOLE.Text & CONSOLE_CACHE & vbCrLf
CONSOLE_CACHE = Round(F1, 2) & " F1 OVERSAMPLING"
CONSOLE_CACHE = CONSOLE_CACHE & CONSOLE_SLASH(CONSOLE_CACHE)
CONSOLE.Text = CONSOLE.Text & CONSOLE_CACHE & vbCrLf
CONSOLE_CACHE = Round(F2, 6) & " F2 CONVERSION"
CONSOLE_CACHE = CONSOLE_CACHE & CONSOLE_SLASH(CONSOLE_CACHE)
CONSOLE.Text = CONSOLE.Text & CONSOLE_CACHE & vbCrLf
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Public Function CONSOLE_SLASH(ByVal STRINGINPUT As String) As String
Dim MAX_SLASH As Integer
Dim CHECK_LEN As Integer
Dim NEW_SIZE As Integer
Dim SLASH_CACHE As String
Dim I As Integer
MAX_SLASH = 40
CHECK_LEN = Len(STRINGINPUT)
NEW_SIZE = MAX_SLASH - CHECK_LEN
SLASH_CACHE = ""
For I = 1 To NEW_SIZE
SLASH_CACHE = SLASH_CACHE & "/"
Next I
CONSOLE_SLASH = SLASH_CACHE
End Function
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub LINK_URL_Click()
Dim internet
Set internet = CreateObject("InternetExplorer.Application")
internet.Visible = True
internet.Navigate ("http://www.paris-studios.de")
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
'//// SCRIPT © REUTLINGER - WWW.PARIS-STUDIOS.DE ///////////////////////////////////////////////////////////////////////////////////////////////////////
