VBA DYNAMIC 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
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
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
VBA.EXCEL 16X CORE MULTI-THREADED MULTICORE
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
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
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 ///////////////////////////////////////////////////////////////////////////////////////////////////////