Views

Histats

Vitrine

Word VBA - Várias Funções - Parte 02.

Function GetSearchPath() Let GetSearchPath = BrowseFolder.BrowseFolder$("Browse Search Folder...") End Function Sub GetControlType() Dim ctrl As Control Dim lngCount As Long Dim ctrlName As String ReDim arrFileTypes(0) Let lngCount = 0

For Each ctrl In frmOptions.framOptions.Controls If ctrl.Name <> "chkShow" And InStr(1, ctrl.Name, "chk") Then Let ctrlName = ctrl.Name

If ctrl.Value = True Then Let arrFileTypes(lngCount) = Right(ctrlName, Len(ctrlName) - 3) ReDim Preserve arrFileTypes(lngCount + 1) End If

End If Next ctrl End Sub

Function FilePathExists(strPickedPath) As Boolean Set objFSO = CreateObject("scripting.
FileSystemObject") If objFSO.FolderExists(strPickedPath) Then Let FilePathExists = True Else Let FilePathExists = False End If End Sub Sub ShowProgress(ByVal snglFileCounter, ByVal snglCount, ByVal strFolderPath As String) Dim snglDecimal As Single Dim snglWidth As Single Dim strLabelText As String If BoolCancel Then Exit Sub Let snglDecimal = snglFileCounter / snglCount Let snglWidth = snglDecimal * 280 Let strLabelText = TruncPathForLabel(strFolderPath) Let frmProgress.lblPercent.Caption = "Folder scan is " & FormatPercent(snglDecimal) & " complete." Let frmProgress.lblStatus.Caption = snglCount & " files in " & strLabelText Let frmProgress.lblProgress.Width = snglWidth frmProgress.Repaint End Sub Sub MakeTable() Dim MyTableRange Dim Active If BoolCancel Then Exit Sub Set Active = ActiveDocument If ActiveDocument.Tables.Count = 0 Then Set MyTableRange = Active.Tables.Add(Range:=Active.Range(Start:=0, End:=0), NumRows:=1, NumColumns:=3) AddMacroButton 1, "MACROBUTTON TableSortAToZ Description " AddMacroButton 2, "MACROBUTTON TableSortAToZ File Path/Name " AddMacroButton 3, "MACROBUTTON TableSortAToZ File Type " With ActiveDocument.Tables(1) .Columns(1).SetWidth ColumnWidth:=InchesToPoints(2.3), RulerStyle:=wdAdjustProportional .Columns(2).SetWidth ColumnWidth:=InchesToPoints(4.5), RulerStyle:=wdAdjustProportional .Columns(3).SetWidth ColumnWidth:=InchesToPoints(0.7), RulerStyle:=wdAdjustProportional End With Let lngTableRows = 1 End If Let BoolTableMade = True End Sub Sub AddMacroButton(ByVal lngCellNumber As Long, ByValstrMacroButton As String) Dim CellRange As Range If BoolCancel Then Exit Sub Set CellRange =ActiveDocument.Tables(1).Rows(1).Cells(lngCellNumber).Range CellRange.Select CellRange.Delete Selection.Fields.Add Range:=CellRange, Type:=wdFieldEmpty,text:=strMacroButton, preserveformatting:=False End Sub Sub pMacroClickOptions() If BoolCancel Then Exit Sub If frmOptions.chkSort.Value = True Then With Options Let .ButtonFieldClicks = 1 End With Else With Options Let .ButtonFieldClicks = 2 End With End If End Sub Function TruncPathForLabel(strText)Dim intLen As Integer Dim intMarkLeft As Integer Dim intMarkRight As Integer Dim strLeft As String Dim strConj As String Dim strRight As String Dim strLabelText As String If BoolCancel Then Exit Function Let intLen = Len(strText) If intLen > 60 Then Let intMarkLeft = InStr(15, strText, "\") Let intMarkRight = InStrRev(strText, "\", -1) Let strLeft = Left(strText, intMarkLeft) Let strConj = "..." Let strRight = "\" & Right(strText, intLen - intMarkRight) Let strLabelText = strLeft & strConj & strRight Let TruncPathForLabel = strLabelText Else Let TruncPathForLabel = strText End If End Sub Sub sOpenBrowser(FileName) Dim Dummy As String Dim RetVal As Long Dim hwnd Let RetVal = ShellExecute(hwnd, "open", FileName, "", Dummy, SW_SHOWNORMAL) End Sub Sub BuildCustomMenu() Dim vCtrlCount As Long Dim ctlControl ''' Always attempt to delete any previously existing ''' custom toolbars when you first start up. ''' Rebuild them rather than trying to reuse them. On Error Resume Next Application.CommandBars("Menu Bar").Controls("docsonline").Delete On Error GoTo 0 ''' Create the custom command bar. Let vCtrlCount = CommandBars("Menu Bar").Controls.Count Let vCtrlCount = vCtrlCount + 1 With CommandBars("Menu Bar").Controls .Add(Type:=msoControlPopup, Before:=vCtrlCount).Caption = "&docsonline" End With 'Make the new menu start the group With CommandBars("Menu Bar").Controls("docsonline") Let .BeginGroup = True End With ''' Add the buttons. Set ctlControl = CommandBars("Menu Bar").Controls("docsonline").Controls.Add(msoControlButton) Let ctlControl.Caption = "&New Catalog" Let ctlControl.Style = msoButtonCaption ''' Display only the caption text." Let ctlControl.OnAction = "NewCatalog" Set ctlControl = CommandBars("Menu Bar").Controls("docsonline").Controls.Add(msoControlButton) Let ctlControl.Caption = "&About docsonline" Let ctlControl.Style = msoButtonCaption ''' Display only the caption text." Let ctlControl.OnAction = "Aboutdocsonline" Let ActiveDocument.Saved = True End Sub Sub NewCatalog() Application.Documents.Add 'Template:=Templates(1).FullName, Visible:=True frmOptions.Show End Sub Sub SetTable() ActiveDocument.Tables(1).Select Let Selection.Font.Size = 9 ActiveDocument.Tables(1).AutoFitBehavior _ wdAutoFitWindow Selection.MoveUp Unit:=wdParagraph, Count:=1, Extend:=False Let ActiveDocument.SpellingChecked = True End Sub Sub CheckTableContents() If ActiveDocument.Tables(1).Rows.Count = 1 Then ActiveDocument.Tables(1).Delete Selection.InsertAfter "There were no files or subfolders in the selected path." End If End Sub Sub DoTheseThings(strFile) Debug.Print strFile End Sub
André Luiz Bernardes A&A - WORK, DON´T PLAY! http://al-bernardes.sites.uol.com.br/ bernardess@gmail.com

✔ VBA Brazil®

✔ VBA Brazil®
brazilsalesforceeffectiveness@gmail.com
Related Posts Plugin for WordPress, Blogger...
diHITT - Notícias