excel2.png
Excel Experts
Microsoft Excel Professionals.
    Home Overview Clients Services Projects Links Contact Excel Vba Download
                             
  A B C D E F G H I J K L M N
1                            
2                            
3   VISUAL BASIC APPLICATION - Code Examples                
4                            
5   Index                        
6   AddNamedRange      
7   ApplyFilterToColumn      
8   CopyPasteMethods      
9   CopyPasteSpecialMethods      
10   CurrentRegion&Resize/Offset+Action      
11   DeleteSpecificNumbersInRange      
12   File Name Only - FUNCTION      
13   FileExists - FUNCTION      
14   FileIsOpen - FUNCTION      
15   FilePathExists - FUNCTION      
16   FileSaveAsDisabled - saves file only with name specified / generated      
17   FindLastRow&LastColumn - FUNCTION - 2 public functions to get LR or LC used in ActiveSheet. can be used repeatedly    
18   FORM-Load      
19   FORM-Unload      
20   GetExternalData - gets data from various sheets in another workbook      
21   GetLastRow      
22   GetLastRowAddress      
23   GetOpenFilename - ALTERNATIVE - 2002 Onwards - Allows filter of files containing specific text using wildcards ie *mytext*    
24   GetOpenFilename1 - ALTERNATIVE - Pre 2002 - Requires Class Module named : clsGetOpenFilename : does as above    
25   GoToLastRow      
26   GoToLastRow-Contiginous      
27   LoopDynamicRange - copy & paste to another sheet based on criteria      
28   MakeCSVFileFromSheet      
29   MakeSheetUnhidden      
30   MakeSheetVeryHidden      
31   MaskedInputBox1 - PUT IN A MODULE NAMED: InputBoxMask1      
32   MaskedInputBox2 - PUT IN A MODULE NAMED: InputBoxMask2      
33   MenuMaker - PUT IN A MODULE NAMED: MenuMaker      
34   PasteSpecialFormulas      
35   PasteSpecialValues      
36   ProtectAllSheets      
37   ResetUsedRange          
38   SelectionFind      
39   SelectionReplace      
40   SelectionSort-NoHeader      
41   SelectToLastRow-Contiginous      
42   UnprotectAllSheets      
43                            
44                            
45   AddNamedRange  
46   ActiveWorkbook.Names.Add Name:="{MY_NAMED_RNG}", RefersTo:="={ENTER_SHEET_NAME}!{ENTER_RANGE_AS_ABSOLUTE}"  
47                            
48   ApplyFilterToColumn        
49   Dim LastRow As Long    
50   Sheets("{SHEET NAME").Select      
51   LastRow = Cells(Rows.Count, "{COLUMN LETTER}").End(xlUp).Row    
52   Range("{COLUMN LETTER}1:{COLUMN LETTER}" & LastRow).Select    
53   Selection.AutoFilter    
54   Selection.AutoFilter Field:=1, Criteria1:={CRITERIA-Enclose in "" if string}    
55                            
56   CopyPasteMethods    
57   Range("A1:B10").Copy Destination:=Range("C1")    
58   'OR    
59   Range("A1:B10").Copy Destination:=Sheets("Sheet2").Range("C1")    
60   'OR    
61   Range("A1:B10").Copy Destination:=Workbooks("Book1").Sheets("Sheet2").Range("C1"    
62                            
63   CopyPasteSpecialMethods    
64   'Whole sheet    
65   Sheets("Sheet1").Cells.Copy    
66   Sheets("Sheet2").PasteSpecial Paste:=xlValues    
67   'Specific range    
68   Sheets("Sheet1").Range("A1:C3").Copy    
69   Sheets("Sheet2").Range("Al").PasteSpecial Paste:=xlValues    
70   Optional XlPasteType - XlPasteType can be one of these XlPasteType constants.    
71   xlPasteAll default    
72   xlPasteAllExceptBorders    
73   xlPasteColumnWidths    
74   xlPasteComments    
75   xlPasteFormats    
76   xlPasteFormulas    
77   xlPasteFormulasAndNumberFormats    
78   xlPasteValidation    
79   xlPasteValues    
80   'xlPasteValuesAndNumberFormats    
81   Optional XlPasteSpecialOperation - XlPasteSpecialOperation can be one of these XlPasteSpecialOperation constants.  
82   xlPasteSpecialOperationAdd    
83   xlPasteSpecialOperationDivide    
84   xlPasteSpecialOperationMultiply    
85   xlPasteSpecialOperationNone default    
86   xlPasteSpecialOperationSubtract    
87                            
88   CurrentRegion&Resize/Offset+Action    
89   '....selects current region and offsets by anumber of rows ie leave header row    
90   Sheets("{SHEET NAME}").Select    
91   Range("{TOP LEFT CELL OF ACTIVE REGION}").Activate    
92   Set tbl = ActiveCell.CurrentRegion    
93   On Error Resume Next    
94   tbl.Offset({ROWS OFFSET}, {COLUMNS OFFSET}).Resize(tbl.Rows.Count - {ROWS OFFSET}, tbl.Columns.Count _    
95   {COLUMNS OFFSET}).{ACTION ie ClearContents, Activate, Select, Copy etc}    
96   On Error GoTo 0    
97                            
98   DeleteSpecificNumbersInRange      
99   Dim {ENTER RANGE VARIABLE NAME} As Range    
100   Set {ENTER RANGE VARIABLE NAME} = Range("{ENTER RANGE}")    
101   For Each cell In {ENTER RANGE VARIABLE NAME}.SpecialCells(xlCellTypeConstants, xlNumbers)    
102   If cell.Value = {ENTER NUMBER CRITERIA} Then    
103   cell.ClearContents    
104   End If    
105   Next cell    
106                            
107   File Name Only - FUNCTION    
108   'The FILE NAME ONLY function    
109   Private Function FileNameOnly(pname) As String    
110   ' Returns the filename from a path/filename string    
111   Dim i As Integer, length As Integer, temp As String    
112   length = Len(pname)    
113   temp = ""    
114   For i = length To 1 Step -1    
115   If Mid(pname, i, 1) = Application.PathSeparator Then    
116   FileNameOnly = temp    
117   Exit Function    
118   End If    
119   temp = Mid(pname, i, 1) & temp    
120   Next i    
121   FileNameOnly = pname    
122   End Function    
123                            
124   FileExists - FUNCTION    
125   'The FILE EXISTS function    
126   Private Function FileExists(fname) As Boolean    
127   ' Returns TRUE if the file exists    
128   Dim x As String    
129   x = Dir(fname)    
130   If x <> "" Then FileExists = True _    
131   Else FileExists = False    
132   End Function    
133                            
134   FileIsOpen - FUNCTION    
135   'The WORKBOOK IS OPEN function    
136   Private Function WorkbookIsOpen(wbname) As Boolean    
137   ' Returns TRUE if the workbook is open    
138   Dim x As Workbook    
139   On Error Resume Next    
140   Set x = Workbooks(wbname)    
141   If Err = 0 Then WorkbookIsOpen = True _    
142   Else WorkbookIsOpen = False    
143   End Function    
144                            
145   FilePathExists - FUNCTION    
146   'The PATH EXISTS function    
147   Private Function PathExists(pname) As Boolean    
148   ' Returns TRUE if the path exists    
149   Dim x As String    
150   On Error Resume Next    
151   x = GetAttr(pname) And 0    
152   If Err = 0 Then PathExists = True _    
153   Else PathExists = False    
154   End Function    
155                            
156   FileSaveAsDisabled - saves file only with name specified / generated    
157   'PLACE IN: Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)    
158   Dim DFN    
159   Application.EnableEvents = False    
160   Application.DisplayAlerts = False    
161   DFN = "{ENTER DEFAULT FILENAME} & ".xls" 'Point to range if file generated name    
162   If ThisWorkbook.Name <> DFN Then    
163   ThisWorkbook.SaveAs ThisWorkbook.Path & "\" & DFN    
164   Application.DisplayAlerts = True    
165   MsgBox ("The file has been saved as : " & DFN)    
166   Application.DisplayAlerts = False    
167   Else    
168   ThisWorkbook.Save    
169   End If    
170   Cancel = True    
171   Application.EnableEvents = True    
172   Application.EnableEvents = True    
173   End Sub    
174                            
175   FindLastRow&LastColumn - FUNCTION - 2 public functions to get LR or LC used in ActiveSheet. can be used repeatedly    
176   'PUT IN MODULE OF WORKBOOK    
177   '--------------------------------------------------------    
178   'Finds the 'LastRow'number of used range of ActiveSheeet.    
179   'Can be used numerous times within procedures.    
180   '--------------------------------------------------------    
181   Public Function LR() As Long    
182   With ActiveSheet    
183   LR = Cells.Find(What:="*", After:=Range("A1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row    
184   End With    
185   End Function    
186   '----------------------------------------------------------    
187   'Finds the 'LastColumn'of the used range in the ActiveSheet    
188   'as a number.    
189   'Can be used numerous times within procedures.    
190   '----------------------------------------------------------    
191   Public Function LC() As Long    
192   With ActiveSheet    
193   LC = Cells.Find(What:="*", After:=Range("A1"), SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column  
194   End With    
195   End Function    
196   'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx    
197   'Sub SomeUsesOF_LR_LC()    
198   ' 'Show results    
199   ' MsgBox (LR)    
200   ' MsgBox (LC)    
201   ' 'Assign to range variable & select    
202   ' Dim MyRange As Range    
203   ' Set MyRange = ActiveSheet.Range("A1:A" & LR)    
204   ' MyRange.Select    
205   ' 'Offset & Resize    
206   ' Set MyRange = MyRange.Offset(1, 0).Resize(LR - 1, LC - 1)    
207   ' MyRange.Select    
208   ' 'Select using RC notation ie cells method    
209   ' Range(Cells(1, 1), Cells(LR, LC)).Select    
210   ' 'Activate last cell    
211   ' Cells(LR, LC).Activate    
212   'End Sub    
213   'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx    
214                            
215   FORM-Load    
216   {NAME OF FORM}.Show    
217                            
218   FORM-Unload    
219   Unload {NAME OF FORM}    
220                            
221   GetExternalData - gets data from various sheets in another workbook      
222   Sub ExtData()    
223   Dim WTfilepath As String    
224   Dim WTfile As String    
225   Dim THISwb As String    
226   Dim myTAB As String    
227   Application.ScreenUpdating = False    
228   'Set variables    
229   WTfilepath = Application.GetOpenFilename(, , "HEADER", , False)    
230   WTfile = FileNameOnly(WTfilepath)    
231   THISwb = FileNameOnly(ThisWorkbook.Name)    
232   'Open the selected workbook and copy data to this workbook    
233   Workbooks.Open WTfile    
234   Workbooks(THISwb).Activate    
235   For Each Sht1 In Workbooks(THISwb).Worksheets    
236   If Len(Sht1.Name) = 2 Then    
237   myTAB = Sht1.Name    
238   Sht1.Range("F5:J11").ClearContents    
239   Sht1.Range("Q5:Q11").ClearContents    
240   On Error Resume Next    
241   Workbooks(WTfile).Sheets(myTAB).Range("D5:H11").Copy    
242   Workbooks(THISwb).Activate    
243   Sheets(myTAB).Select    
244   Range("F5").Select    
245   Selection.PasteSpecial Paste:=xlValues    
246   On Error GoTo 0    
247   End If    
248   Next Sht1    
249   Workbooks(WTfile).Close savechanges:=False    
250   End Sub    
251                            
252   GetLastRow    
253   Dim {VAR_NAME} As Long    
254   {VAR_NAME}= Cells(Rows.Count, "{ENTER_COL_HERE}").End(xlUp).Row    
255                            
256   GetLastRowAddress    
257   Dim {ENTER_VARIABLE_NAME} As String    
258   Cells(Rows.Count, "{ENTER_COLUMN_LETTER}").End(xlUp).Activate    
259   {ENTER_VARIABLE_NAME} = ActiveCell.Address    
260                            
261   GetOpenFilename - ALTERNATIVE - 2002 Onwards - Allows filter of files containing specific text using wildcards ie *mytext*  
262   Dim CDfilepath As Variant    
263   Dim CDfile As String    
264   With Application.FileDialog(msoFileDialogFilePicker)    
265   .AllowMultiSelect = False    
266   .Filters.Add "Excel files (*.xls)", "*.xls", 1    
267   .FilterIndex = 1    
268   .Title = "Please select the previous week's TBREC-WK file."    
269   .InitialFileName = "TBREC-WK*.xls"    
270   If .Show = True Then CDfilepath = .SelectedItems(1) 'change CDfilepath to Workbooks.Open to open selected file  
271   End With    
272   CDfile = FileNameOnly(CDfilepath) 'Note FileNameOnly function    
273   'code to do what you want here    
274                            
275   GetOpenFilename1 - ALTERNATIVE - Pre 2002 - Requires Class Module named : clsGetOpenFilename : does as above    
276   'CODE SOURCE & AUTHOR    
277   '--------------------------------------------------------------------------------------    
278   ' http://groups.google.com/group/microsoft.public.excel.programming/msg/f8e66f9e6f73cc4    
279   ' by Bob Phillips    
280   ' cited in http://www.dailydoseofexcel.com/archives/2004/06/09/getopenfilename/    
281   '--------------------------------------------------------------------------------------    
282   'IMPORTANT    
283   '--------------------------------------------------------------------------------------    
284   'This Sub will not run unless the appropriate code is placed in a Class Module named    
285   'clsGetOpenFilename. See notes in Class Module for more information.    
286   '--------------------------------------------------------------------------------------    
287   'WHAT IT DOES    
288   '--------------------------------------------------------------------------------------    
289   'Displays a list of files that are filtered dependent on the filename and / or    
290   'extension. Wildcards can be used.    
291   '.SelectedFiles(1) returns the PATH & FILENAME selected    
292   '--------------------------------------------------------------------------------------    
293   Sub OpenFiles()    
294   Dim cFileOpen As clsGetOpenFileName    
295   Dim MYfilepath As Variant 'Added by Excel Experts    
296   Set cFileOpen = New clsGetOpenFileName    
297   '----------------------------------------------------------------------------------    
298   'Clicking OPEN will return the file selected.    
299   'Clicking CANCEL will close the dialog box.    
300   With cFileOpen    
301   .FileName = "TBREC-WK*.xls" 'Enter filename & type req'd    
302   .FileType = "Excel Files" 'Text you want to appear    
303   .DialogTitle = "Please select the correct file." 'Text for Dialog box title    
304   .MultiFile = "N" 'Returns array if Y    
305   .SelectFile    
306   If .SelectedFiles.Count > 0 Then 'Checks file is selected    
307   MYfilepath = .SelectedFiles(1) 'Assigns filename to variable    
308   'ALTERNATVE    
309   'Workbooks.Open .SelectedFiles(1) 'Added by Excel Experts    
310   Else    
311   MsgBox ("You did not select a file.") 'Added by Excel Experts    
312   End If    
313   End With    
314   Set cFileOpen = Nothing    
315   '----------------------------------------------------------------------------------    
316   'Insert code here to use variable MYfilepath    
317   'if ALTERNATIVE is not used    
318   If MYfilepath <> "" Then    
319   MsgBox ("You selected the file: " & MYfilepath)    
320   End If    
321   End Sub    
322                            
323   GoToLastRow    
324   Cells(Rows.Count, "{ENTER_COLUMN_LETTER}").End(xlUp).Activate    
325                            
326   GoToLastRow-Contiginous    
327   ActiveCell.End(xlDown).Activate    
328   'OR    
329   Selection.End(xlDown).Select    
330                            
331   LoopDynamicRange - copy & paste to another sheet based on criteria    
332   Dim {ENTER_LASTROW_VARIABLE_NAME} As Long    
333   Dim tr As Long    
334   {ENTER_LASTROW_VARIABLE_NAME} = Cells(Rows.Count, "{ENTER_COLUMN_TO_FIND_LAST_ROW}").End(xlUp).Row    
335   For i = {ENTER_LASTROW_VARIABLE_NAME} To 1 Step -1    
336   Cells(i, "{ENTER_COLUMN_TO_FIND_LAST_ROW}").Select    
337   If ActiveCell.Value = "{ENTER CRITERIA}" Then    
338   Range("{ENTER COPY FROM COLUMN}" & i).Copy Destination:=Sheets("{ENTER DESTINATION WORKSHEET}").Range_  
339   ("{ENTER COPY TO COLUMN}" & i)    
340   End If    
341   Next i    
342                            
343   MakeCSVFileFromSheet    
344   Sub makeCSV()    
345   Dim wbp As String    
346   Dim fn As String    
347   Dim lr As Long    
348   '....apply values to variables    
349   wbp = ThisWorkbook.Path    
350   fn = "{NAME FOR CSV FILE}"    
351   '....copy sheet to new workbook    
352   Sheets("Journal").Copy    
353   With ActiveSheet    
354   Application.DisplayAlerts = False    
355   'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx    
356   'do stuff to sheet such as deleting rows with 0 amount in column H    
357   'lr = Cells(Rows.Count, "A").End(xlUp).Row    
358   'For i = lr To 1 Step -1    
359   'If Cells(i, "H").Value = 0 Then    
360   'Rows(i).Delete    
361   'End If    
362   'Next i    
363   'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx    
364   'save the file in the specified directory with assigned filename    
365   .SaveAs Filename:=wbp & "\" & fn , FileFormat:=xlCSV    
366   Application.DisplayAlerts = True    
367   End With    
368   '....close newly created file    
369   Workbooks(fn & "-CSV").Close savechanges:=False    
370   MsgBox ("The CSV journal file has been saved as follows: " & wbp & "\" & fn)    
371   End Sub    
372                            
373   MakeSheetUnhidden      
374   Worksheets("{ENTER_SHEET_NAME}").Visible = xlSheetVisible    
375                            
376   MakeSheetVeryHidden    
377   Worksheets("{ENTER_SHEET_NAME}").Visible = xlVeryHidden    
378                            
379   MaskedInputBox1 - PUT IN A MODULE NAMED: InputBoxMask1      
380   Option Explicit    
381   'TO USE:    
382   'variable = InputBoxDK    
383   '// My thanks to:    
384   '// Ken Getz and Michael Kaplan    
385   '// For their brilliant work with    
386   '// Using Callbacks with Office 97    
387   '// KNG Consulting, Inc.    
388   '// Copyright 1998    
389   '// Ken Getz & Michael Kaplan    
390   '// All rights reserved.    
391   '-------------------------------------------------------------------------------------------------------------------    
392   ' Declarations    
393   '    
394   ' These function names were puzzled out by using DUMPBIN /exports    
395   ' with VBA332.DLL and then puzzling out parameter names and types    
396   ' through a lot of trial and error and over 100 IPFs in MSACCESS.EXE    
397   ' and VBA332.DLL.    
398   '    
399   ' These parameters may not be named properly but seem to be correct in    
400   ' light of the function names and what each parameter does.    
401   '    
402   ' EbGetExecutingProj: Gives you a handle to the current VBA project    
403   ' TipGetFunctionId: Gives you a function ID given a function name    
404   ' TipGetLpfnOfFunctionId: Gives you a pointer a function given its function ID    
405   '    
406   '-------------------------------------------------------------------------------------------------------------------    
407   Private Declare Function GetCurrentVbaProject _    
408   Lib "vba332.dll" _    
409   Alias "EbGetExecutingProj" ( _    
410   hProject As Long) _    
411   As Long    
412   Private Declare Function GetFuncID _    
413   Lib "vba332.dll" _    
414   Alias "TipGetFunctionId" ( _    
415   ByVal hProject As Long, _    
416   ByVal strFunctionName As String, _    
417   ByRef strFunctionId As String) _    
418   As Long    
419   Private Declare Function GetAddr _    
420   Lib "vba332.dll" _    
421   Alias "TipGetLpfnOfFunctionId" ( _    
422   ByVal hProject As Long, _    
423   ByVal strFunctionId As String, _    
424   ByRef lpfn As Long) _    
425   As Long    
426   '-------------------------------------------------------------------------------------------------------------------    
427   ' AddrOf    
428   '    
429   ' Returns a function pointer of a VBA public function given its name. This function    
430   ' gives similar functionality to VBA as VB5 has with the AddressOf param type.    
431   '    
432   ' NOTE: This function only seems to work if the proc you are trying to get a pointer    
433   ' to is in the current project. This makes sense, since we are using a function    
434   ' named EbGetExecutingProj.    
435   '-------------------------------------------------------------------------------------------------------------------    
436   Public Function AddrOf(strFuncName As String) As Long    
437   Dim hProject As Long    
438   Dim lngResult As Long    
439   Dim strID As String    
440   Dim lpfn As Long    
441   Dim strFuncNameUnicode As String    
442      
443   Const NO_ERROR = 0    
444      
445   ' The function name must be in Unicode, so convert it.    
446   strFuncNameUnicode = StrConv(strFuncName, vbUnicode)    
447      
448   ' Get the current VBA project    
449   ' The results of GetCurrentVBAProject seemed inconsistent, in our tests,    
450   ' so now we just check the project handle when the function returns.    
451   Call GetCurrentVbaProject(hProject)    
452      
453   ' Make sure we got a project handle... we always should, but you never know!    
454   If hProject <> 0 Then    
455   ' Get the VBA function ID (whatever that is!)    
456   lngResult = GetFuncID( _    
457   hProject, strFuncNameUnicode, strID)    
458      
459   ' We have to check this because we GPF if we try to get a function pointer    
460   ' of a non-existent function.    
461   If lngResult = NO_ERROR Then    
462   ' Get the function pointer.    
463   lngResult = GetAddr(hProject, strID, lpfn)    
464      
465   If lngResult = NO_ERROR Then    
466   AddrOf = lpfn    
467   End If    
468   End If    
469   End If    
470   End Function    
471                            
472   MaskedInputBox2 - PUT IN A MODULE NAMED: InputBoxMask2      
473   Option Explicit    
474   'TO USE:    
475   'variable = InputBoxDK    
476   '////////////////////////////////////////////////////////////////////    
477   'Password masked inputbox    
478   'Allows you to hide characters entered in a VBA Inputbox.    
479   'Code written by Daniel Klann    
480   'http://www.danielklann.com/    
481   'March 2003    
482   '// Kindly permitted to be amended    
483   '// Amended by Ivan F Moala    
484   '// http://www.xcelfiles.com    
485   '// April 2003    
486   '// Works for Xl2000+ due the AddressOf Operator    
487   '//    
488   '// Amended 5th March 2004 for Gopal    
489   '// This allows it to be run on Xl97+    
490   '////////////////////////////////////////////////////////////////////    
491   'API functions to be used    
492   Private Declare Function CallNextHookEx _    
493   Lib "user32" ( _    
494   ByVal hHook As Long, _    
495   ByVal ncode As Long, _    
496   ByVal wParam As Long, _    
497   lParam As Any) _    
498   As Long    
499   Private Declare Function GetModuleHandle _    
500   Lib "kernel32" _    
501   Alias "GetModuleHandleA" ( _    
502   ByVal lpModuleName As String) _    
503   As Long    
504   Private Declare Function SetWindowsHookEx _    
505   Lib "user32" _    
506   Alias "SetWindowsHookExA" ( _    
507   ByVal idHook As Long, _    
508   ByVal lpfn As Long, _    
509   ByVal hmod As Long, _    
510   ByVal dwThreadId As Long) _    
511   As Long    
512   Private Declare Function UnhookWindowsHookEx _    
513   Lib "user32" ( _    
514   ByVal hHook As Long) _    
515   As Long    
516   Private Declare Function SendDlgItemMessage _    
517   Lib "user32" Alias "SendDlgItemMessageA" ( _    
518   ByVal hDlg As Long, _    
519   ByVal nIDDlgItem As Long, _    
520   ByVal wMsg As Long, _    
521   ByVal wParam As Long, _    
522   ByVal lParam As Long) _    
523   As Long    
524   Private Declare Function GetClassName _    
525   Lib "user32" _    
526   Alias "GetClassNameA" ( _    
527   ByVal hwnd As Long, _    
528   ByVal lpClassName As String, _    
529   ByVal nMaxCount As Long) _    
530   As Long    
531   Private Declare Function GetCurrentThreadId _    
532   Lib "kernel32" () _    
533   As Long    
534   'Constants to be used in our API functions    
535   Private Const EM_SETPASSWORDCHAR = &HCC    
536   Private Const WH_CBT = 5    
537   Private Const HCBT_ACTIVATE = 5    
538   Private Const HC_ACTION = 0    
539   Private hHook As Long    
540   Public Function NewProc(ByVal lngCode As Long, _    
541   ByVal wParam As Long, _    
542   ByVal lParam As Long) As Long    
543   Dim RetVal As Long    
544   Dim strClassName As String, lngBuffer As Long    
545   If lngCode < HC_ACTION Then    
546   NewProc = CallNextHookEx(hHook, lngCode, wParam, lParam)    
547   Exit Function    
548   End If    
549   strClassName = String$(256, " ")    
550   lngBuffer = 255    
551   If lngCode = HCBT_ACTIVATE Then 'A window has been activated    
552   RetVal = GetClassName(wParam, strClassName, lngBuffer)    
553   If Left$(strClassName, RetVal) = "#32770" Then 'Class name of the Inputbox    
554   'This changes the edit control so that it display the password character *.    
555   'You can change the Asc("*") as you please.    
556   SendDlgItemMessage wParam, &H1324, EM_SETPASSWORDCHAR, Asc("*"), &H0    
557   End If    
558   End If    
559      
560   'This line will ensure that any other hooks that may be in place are    
561   'called correctly.    
562   CallNextHookEx hHook, lngCode, wParam, lParam    
563   End Function    
564   '// Make it public = avail to ALL Modules    
565   '// Lets simulate the VBA Input Function    
566   Public Function InputBoxDK(Prompt As String, Optional Title As String, _    
567   Optional Default As String, _    
568   Optional Xpos As Long, _    
569   Optional Ypos As Long, _    
570   Optional Helpfile As String, _    
571   Optional Context As Long) As String    
572      
573   Dim lngModHwnd As Long, lngThreadID As Long    
574      
575   '// Lets handle any Errors JIC! due to HookProc> App hang!    
576   On Error GoTo ExitProperly    
577   lngThreadID = GetCurrentThreadId    
578   lngModHwnd = GetModuleHandle(vbNullString)    
579      
580   #If VBA6 Then    
581   hHook = SetWindowsHookEx(WH_CBT, AddressOf NewProc, lngModHwnd, lngThreadID)    
582   #Else    
583   hHook = SetWindowsHookEx(WH_CBT, AddrOf("NewProc"), lngModHwnd, lngThreadID)    
584   #End If    
585   If Xpos Then    
586   InputBoxDK = InputBox(Prompt, Title, Default, Xpos, Ypos, Helpfile, Context)    
587   Else    
588   InputBoxDK = InputBox(Prompt, Title, Default, , , Helpfile, Context)    
589   End If    
590   ExitProperly:    
591   UnhookWindowsHookEx hHook    
592   End Function    
593   Sub TestDKInputBox()    
594   Dim x As String    
595   x = InputBoxDK("Type your password here.", "Password Required", "test")    
596   If x = "" Then End    
597   If x <> "yourpassword" Then    
598   MsgBox "You didn't enter a correct password."    
599   End    
600   End If    
601   MsgBox "Welcome Creator!", vbExclamation    
602      
603   End Sub                        
604                            
605   MenuMaker - PUT IN A MODULE NAMED: MenuMaker      
606   Option Explicit    
607   'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx    
608   'IMPORTANT: TAKE THE FOLLOWING 4 ACTIONS.    
609   ' 1) Call CreateMenu ------- workbook_open event    
610   ' 2) Call DeleteMenu ------- workbook_beforeclose    
611   ' 3) IMPORT Worksheet called MenuSheet(on PERSONALSTC.xls)    
612   ' 4) REMEMBER assign macro's on the worksheet buttons    
613   'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx    
614   Sub CreateMenu()    
615   ' This sub should be executed when the workbook is opened.    
616   ' NOTE: There is no error handling in this subroutine    
617   Dim MenuSheet As Worksheet    
618   Dim MenuObject As CommandBarPopup    
619   Dim MenuItem As Object    
620   Dim SubMenuItem As CommandBarButton    
621   Dim Row As Integer    
622   Dim MenuLevel, NextLevel, PositionOrMacro, Caption, Divider, FaceId    
623   ''''''''''''''''''''''''''''''''''''''''''''''''''''    
624   ' Location for menu data    
625   Set MenuSheet = ThisWorkbook.Sheets("MenuSheet")    
626   ''''''''''''''''''''''''''''''''''''''''''''''''''''    
627   ' Make sure the menus aren't duplicated    
628   Call DeleteMenu    
629   ' Initialize the row counter    
630   Row = 2    
631   ' Add the menus, menu items and submenu items using    
632   ' data stored on MenuSheet    
633   Do Until IsEmpty(MenuSheet.Cells(Row, 1))    
634   With MenuSheet    
635   MenuLevel = .Cells(Row, 1)    
636   Caption = .Cells(Row, 2)    
637   PositionOrMacro = .Cells(Row, 3)    
638   Divider = .Cells(Row, 4)    
639   FaceId = .Cells(Row, 5)    
640   NextLevel = .Cells(Row + 1, 1)    
641   End With    
642   Select Case MenuLevel    
643   Case 1 ' A Menu    
644   ' Add the top-level menu to the Worksheet CommandBar    
645   Set MenuObject = Application.CommandBars(1). _    
646   Controls.Add(Type:=msoControlPopup, _    
647   Before:=PositionOrMacro, _    
648   Temporary:=True)    
649   MenuObject.Caption = Caption    
650   Case 2 ' A Menu Item    
651   If NextLevel = 3 Then    
652   Set MenuItem = MenuObject.Controls.Add(Type:=msoControlPopup)    
653   Else    
654   Set MenuItem = MenuObject.Controls.Add(Type:=msoControlButton)    
655   MenuItem.OnAction = PositionOrMacro    
656   End If    
657   MenuItem.Caption = Caption    
658   If FaceId <> "" Then MenuItem.FaceId = FaceId    
659   If Divider Then MenuItem.BeginGroup = True    
660   Case 3 ' A SubMenu Item    
661   Set SubMenuItem = MenuItem.Controls.Add(Type:=msoControlButton)    
662   SubMenuItem.Caption = Caption    
663   SubMenuItem.OnAction = PositionOrMacro    
664   If FaceId <> "" Then SubMenuItem.FaceId = FaceId    
665   If Divider Then SubMenuItem.BeginGroup = True    
666   End Select    
667   Row = Row + 1    
668   Loop    
669   End Sub    
670   Sub DeleteMenu()    
671   ' This sub should be executed when the workbook is closed    
672   ' Deletes the Menus    
673   Dim MenuSheet As Worksheet    
674   Dim Row As Integer    
675   Dim Caption As String    
676   On Error Resume Next    
677   Set MenuSheet = ThisWorkbook.Sheets("MenuSheet")    
678   Row = 2    
679   Do Until IsEmpty(MenuSheet.Cells(Row, 1))    
680   If MenuSheet.Cells(Row, 1) = 1 Then    
681   Caption = MenuSheet.Cells(Row, 2)    
682   Application.CommandBars(1).Controls(Caption).Delete    
683   End If    
684   Row = Row + 1    
685   Loop    
686   On Error GoTo 0    
687   End Sub    
688   Sub DummyMacro()    
689   MsgBox "This macro is not yet avaialable."    
690   End Sub    
691                            
692   PasteSpecialFormulas    
693   Selection.PasteSpecial Paste:=xlFormulas    
694                            
695   PasteSpecialValues    
696   Selection.PasteSpecial Paste:=xlValues    
697                            
698   ProtectAllSheets    
699   Sub Protectallsheets()    
700   Application.ScreenUpdating = False    
701   Dim Filename As String    
702   Filename = ActiveWorkbook.Name    
703   For Each Sht1 In Workbooks(Filename).Worksheets    
704   Sht1.DisplayAutomaticPageBreaks = False    
705   Sht1.Protect ("{ENTER_PASSWORD}"), userinterfaceonly:=True    
706   Sht1.EnableAutoFilter = True    
707   Next Sht1    
708   End Sub    
709                            
710   ResetUsedRange    
711   Sub ResetUsedRange()    
712   Dim myLastRow As Long    
713   Dim myLastCol As Long    
714   Dim wks As Worksheet    
715   Dim dummyRng As Range    
716   Dim MyWks    
717   For Each wks In ActiveWorkbook.Worksheets    
718   MyWks = wks.Name    
719   With wks    
720   myLastRow = 0    
721   myLastCol = 0    
722   Set dummyRng = .UsedRange    
723   On Error Resume Next    
724   myLastRow = _    
725   .Cells.Find("*", after:=.Cells(1), _    
726   LookIn:=xlFormulas, lookat:=xlWhole, _    
727   searchdirection:=xlPrevious, _    
728   searchorder:=xlByRows).Row    
729   myLastCol = _    
730   .Cells.Find("*", after:=.Cells(1), _    
731   LookIn:=xlFormulas, lookat:=xlWhole, _    
732   searchdirection:=xlPrevious, _    
733   searchorder:=xlByColumns).Column    
734   On Error GoTo 0    
735   If myLastRow * myLastCol = 0 Then    
736   .Columns.Delete    
737   Else    
738   .Range(.Cells(myLastRow + 1, 1), _    
739   .Cells(.Rows.Count, 1)).EntireRow.Delete    
740   .Range(.Cells(1, myLastCol + 1), _    
741   .Cells(1, .Columns.Count)).EntireColumn.Delete    
742   End If    
743   End With    
744   Next wks    
745   End Sub    
746                            
747   SelectionFind    
748   On Error Resume Next    
749   Selection.Find(What:={FIND - enclose in "" if string}, after:=ActiveCell, LookIn:=xlValues, _    
750   lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlNext, _    
751   MatchCase:=False, SearchFormat:=False).Row    
752   On Error GoTo 0    
753                            
754   SelectionReplace    
755   Range("A1").Select    
756   Range(Selection, Selection.End(xlDown)).Select    
757   Selection.Replace What:={REPLACE WHAT? - enclose in "" if string}, Replacement:={WITH - enclose in "" if string}, lookat:=xlPart, _  
758   searchorder:=xlByRows, MatchCase:=False, SearchFormat:=False, _    
759   ReplaceFormat:=False    
760                          
761   SelectionSort-NoHeader    
762   Selection.Sort Key1:=Range("A2"), Order1:=xlDescending, Header:=xlNo, _    
763   OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom    
764                          
765   SelectToLastRow-Contiginous    
766   Range(Selection, Selection.End(xlDown)).Select    
767   'OR    
768   Range(ActiveCell, ActiveCell.End(xlDown)).Select    
769                            
770   UnprotectAllSheets    
771   Sub Unprotectallsheets()    
772   Application.ScreenUpdating = False    
773   Dim Filename As String    
774   Filename = ActiveWorkbook.Name    
775   For Each Sht1 In Workbooks(Filename).Worksheets    
776   Sht1.Unprotect ("{ENTER_PASSWORD}")    
777   Next Sht1    
778   End Sub    
779                            
780                            
781                            
782                            
783                            
784                            
785                            
786                            
787                            
788                            
789                            
790                            
791                            
792                            
793                            
794                            
795                            
796                            
797                            
798                            
799                            
800                            
801                            
802                            
803                            
804                            
805                            
806                            
807                            
808                            
809                            
810                            
811                            
812                            
813                            
814                            
815                            
816                            
817                            
818                            
819                            
820                            
821                            
822                            
823                            
824                            
825                            
826                            
827                            
828                            
829                            
830                            
831                            
832                            
833                            
834                            
835                            
836                            
837                            
838                            
839                            
840                            
841                            
842                            
843                            
844                            
845                            
846                            
847                            
848                            
849                            
850                            
851                            
852                            
853                            
854                            
855                            
856                            
857                            
858                            
859                            
860                            
861                            
862                            
863                            
864                            
865                            
866                            
867                            
868                            
869                            
870                            
871                            
872                            
873                            
874                            
875                            
876                            
877                            
878                            
879                            
880                            
881                            
882                            
883                            
884                            
885                            
886                            
887                            
888                            
889                            
890                            
891                            
892                            
893                            
894                            
895                            
896                            
897                            
898                            
899                            
900                            
901                            
902                            
903                            
904                            
905                            
906                            
907                            
908                            
909                            
910                            
911                            
912                            
913                            
914                            
915                            
916                            
917                            
918                            
919                            
920                            
921                            
922                            
923                            
924                            
925                            
926                            
927                            
928                            
929                            
930                            
931                            
932                            
933                            
934                            
935                            
936                            
937                            
938                            
939                            
940                            
941                            
942                            
943                            
944                            
945                            
946                            
947                            
948                            
949                            
950                            
951                            
952                            
953                            
954                            
955                            
956                            
957                            
958                            
959                            
960                            
961                            
962                            
963                            
964                            
965                            
966                            
967                            
968                            
969                            
970                            
971                            
972                            
973                            
974                            
975                            
976                            
977                            
978                            
979                            
980                            
981                            
982                            
983                            
984                            
985                            
986                            
987                            
988                            
989                            
990                            
991                            
992                            
993                            
994                            
995                            
996                            
997                            
998                            
999