My Main Module
Option Explicit
Option Private Module
Private Const cModule As String = "modMain"
Global Const AprvdSavers As String = "porthosdev"
Global Const AprvdSavers2 As String = "cortea13"
Global Const Tombstone As String = "@~@"
Global Const Success As Boolean = False
Global Const Failure As Boolean = True
Global Const NoError As Long = 0 'No Error
Global Const LogError As Long = 997 'Log Error
Global Const RtnError As Long = 998 'Return Error
Global Const DspError As Long = 999 'Display Error
Global Const MAX_PATH = 255
Global IsLogin As Boolean
Public Enum DB_Engine
DB_USE_ACCESS = 0
DB_USE_MSSQL = 1
DB_USE_MYSQL = 2
End Enum
Public Enum WOStatus
WO_Open = 0
WO_Close = 1
WO_NCMR = 2
End Enum
Public AppUnload As Boolean
Public IsConnected As Boolean
Public ConnString As String
Public Conn As ADODB.Connection
Public DBType As DB_Engine
Public CurrDate As String
Public Const AppName As String = "WOMonitoring"
Public DefDepCode As String 'Default DepCode
Public DepID As Long
Public oUsers As Users
Public Sub CheckID()
Dim user As String
Dim lngRetVal As Long
Dim intStatus As Integer
Dim v
If Not IsConnected Then
If Not TryConnect Then MsgBox "Unable to connect to Database.", vbCritical: Exit Sub
End If
If IsValiD(oUsers) Then Set oUsers = Nothing
Set oUsers = New Users
user = GetUser
If user <> "" Then
oUsers.Username = UCase$(user)
lngRetVal = oUsers.Find
'If not found
If lngRetVal < 0 Then
'Show the users form to update dep line and shift
With frmUserDetail
intStatus = 1
oUsers.Username = user
v = .Component(oUsers, intStatus)
If Not v Then
'User cancelled
End If
End With
End If
lngRetVal = oUsers.Find
If lngRetVal = 0 Then
DepID = oUsers.DepID
DefDepCode = DepID
IsLogin = True
Else
MsgBox oUsers.ErrorDesc
Exit Sub
End If
End If
End Sub
Public Function Show_UsersList(Optional ByRef Control As IRibbonControl) As Boolean
On Error Resume Next
Dim v
If Not IsLogin Then CheckID
v = frmUserList.prompt
Unload frmUserList
End Function
Public Function Show_ProductsList(Optional ByRef Control As IRibbonControl) As Boolean
On Error Resume Next
Dim v
If Not IsLogin Then CheckID
v = frmProductList.prompt
Unload frmProductList
Show_ProductsList = True
End Function
Public Function Show_ToolsList(Optional ByRef Control As IRibbonControl) As Boolean
On Error Resume Next
Dim v
If Not IsLogin Then CheckID
v = frmTools.prompt
Unload frmTools
Show_ToolsList = True
End Function
Public Function Show_Report(Optional ByRef Control As IRibbonControl) As Boolean
' MsgBox "Report Module"
Dim sSQL As String
Dim rs As ADODB.Recordset
On Error GoTo PROC_ERR
If Not IsLogin Then CheckID
sSQL = "SELECT Product.*,UOMTable.* FROM (Product LEFT JOIN UOMTable ON Product.PackID = UOMTable.UomID) WHERE Product.DepID = 1 AND Product.Active = -1 "
Set rs = New ADODB.Recordset
Set rs.ActiveConnection = Conn
rs.Open sSQL
Sheet1.Range("A1").CopyFromRecordset rs
With Worksheets("Reports")
.Activate
.PrintOut Preview:=True
End With
rs.Close
Show_Report = True
Sheet2.Activate
Exit Function
PROC_ERR:
MsgBox "Error: " & Err.Description
End Function
Public Function Show_Setup(Optional ByRef Control As IRibbonControl) As Boolean
On Error Resume Next
Dim v
If Not IsLogin Then CheckID
v = frmSettings.prompt
Unload frmSettings
End Function
Public Function Show_SQLQuery(Optional ByRef Control As IRibbonControl) As Boolean
MsgBox "SQL Query Module"
Show_SQLQuery = True
End Function
Public Function Show_MainWO(Optional ByRef Control As IRibbonControl) As Boolean
' Description:Setup workbook when opened
' Inputs: *None
' Outputs: *None
' Requisites: Classes clsWorkbook
' Routines modGeneral.SavCls
' Example: ?UpdCSTUI()
' Date Ini Modification
' 06/15/16 CWH Initial Development
' Declarations
Const cRoutine As String = "UpdCSTUI"
Dim oWkb As clsWorkbook
Dim v
' Error Handling Initialization
On Error GoTo ErrHandler
' Procedure
If Not IsLogin Then CheckID
' Set oWkb = New clsWorkbook
' Set oWkb.Workbook = ThisWorkbook
' oWkb.Workbook_Open
'Save a reference to our class server
' SavCls ThisWorkbook.Name & "!clsWorkbook", oWkb
'IsConnected = True: MsgBox "Connected"
frmMainForm.show 'vbModeless
'oWkb.MyForm.show 'vbModeless
'ShowMainForm
'While oWkb.MyForm.Visible: DoEvents: Wend
' Else
' MsgBox "Error Connecting to " & dbPath
' End If
' Else
' MsgBox "Database not found.", vbCritical
' End If
Show_MainWO = Success
ErrHandler:
Select Case Err.Number
Case Is = NoError: 'Do nothing
Case Else:
Select Case DspErrMsg(cModule & "." & cRoutine)
Case Is = vbAbort: Stop: Resume 'Debug mode - Trace
Case Is = vbRetry: Resume 'Try again
Case Is = vbIgnore: 'End routine
End Select
End Select
End Function
Public Sub Auto_Open()
' Description:Setup workbook when opened
' Inputs: *None
' Outputs: *None
' Requisites: Classes clsWorkbook
' Routines modGeneral.SavCls
' Example: ?UpdCSTUI()
' Date Ini Modification
' 06/15/16 CWH Initial Development
' Declarations
Const cRoutine As String = "Auto_Open"
' Dim oWkb As clsWorkbook
' Error Handling Initialization
On Error GoTo ErrHandler
' Call RenderXP
' Procedure
' Debug.Print "Auto_Open() is fired."
' Set oWkb = New clsWorkbook
' Set oWkb.Workbook = ThisWorkbook
' oWkb.Workbook_Open
' SavCls ThisWorkbook.Name & "!clsWorkbook", oWkb
ErrHandler:
Select Case Err.Number
Case Is = NoError: 'Do nothing
Case Else:
Select Case DspErrMsg(cModule & "." & cRoutine)
Case Is = vbAbort: Stop: Resume 'Debug mode - Trace
Case Is = vbRetry: Resume 'Try again
Case Is = vbIgnore: 'End routine
End Select
End Select
End Sub
Private Sub ShowMainForm()
frmMainForm.show vbModeless
End Sub
Public Function TryConnect() As Boolean
Dim dbPath As String
Dim Res As Long
Dim v
DBType = DB_USE_ACCESS
'Reset the path to Database
'SaveMySetting "System Settings", "DBPath", vbNullString
dbPath = vbNullString
'dbPath = ThisWorkbookPath & "WOrderDb.mdb"
'dbPath = GetMySetting("System Settings", "DBPath")
If dbPath = "" Then
dbPath = ThisWorkbookPath & "WOrderDb.mdb"
'If Len(Dir$(dbPath)) <= 0 Then
'Create an empty front end database
Res = CreateEmptyDB(dbPath)
If Res > 0 Then
'Link the tables from remote db to this local db
v = frmTableLinks.prompt(dbPath)
Unload frmTableLinks
'Save the db path in registry
SaveMySetting "System Settings", "DBPath", dbPath
End If
End If
If Len(Dir$(dbPath)) > 0 Then
'ConnString = "Provider=Microsoft.Jet.OLEDB.4.0;User ID=Admin;Data Source=" & dbPath & ";Mode=Share Deny None;Extended Properties="""";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Database Password=nf58wazd;Jet OLEDB:Engine Type=4;Jet OLEDB:Database Locking Mode=0;Jet OLEDB:Global Partial Bulk Ops=2;Jet OLEDB:Global Bulk Transactions=1;Jet OLEDB:New Database Password="""";Jet OLEDB:Create System Database=False;Jet OLEDB:Encrypt Database=False;Jet OLEDB:Don't Copy Locale on Compact=False;Jet OLEDB:Compact Without Replica Repair=False;Jet OLEDB:SFP=False"
ConnString = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" & dbPath & ";"
'& "Jet OLEDB:Database Password=1234" 'User Id=admin;Password=mauia"
Set Conn = New ADODB.Connection
If Connect(ConnString) Then IsConnected = True
TryConnect = IsConnected
End If
End Function
Public Function Connect(Optional ByVal m_ConnectString As String, _
Optional ByVal CursorLocation As CursorLocationEnum = adUseClient) As Boolean
On Error GoTo Err_Connect
Connect = False
Conn.CursorLocation = CursorLocation
If m_ConnectString = "" Then
' Conn.Open m_DefaultConnectionString
Else
Conn.Open m_ConnectString
Connect = True
End If
Exit Function
Err_Connect:
Call ErrorMsg(Err.Number, Err.Description, "modADO", "Connect")
End Function
Public Function ThisWorkbookPath() As String
ThisWorkbookPath = ThisWorkbook.FullName
ThisWorkbookPath = Left$(ThisWorkbookPath, InStrRev(ThisWorkbookPath, "\"))
End Function
Public Function ErrorMsg(ErrNum As Long, _
ErrDesc As String, _
strFunction As String, _
strModule As String)
On Error Resume Next
Dim anErrorMessage As String
Dim lngRetVal As Long
anErrorMessage = "Error Number: " & ErrNum & "." & vbCrLf & "Error Description: " & ErrDesc & vbCrLf & "Module Name: " & strModule & vbCrLf & "Sub/Function: " & strFunction & vbCrLf
'If IsValid(fMainForm) Then
' lngRetval = fMainForm.LoadDialogBoxSimple("An error occured in " & strModule & " Function/Sub " & strFunction & "", ErrDesc, TaskButtonOk, TaskButtonOk, IconError, , AppName)
'Else
MsgBox anErrorMessage, vbCritical
'End If
End Function
Public Function DspErrMsg(ByVal cRoutineName As String, _
Optional ByVal sAddText As String = "")
' Description:Display an unanticipated error message
' Inputs: RoutineName Function or Subroutine's name
' AddText Additional Text
' Outputs: *None
' Requisites: Constants me.AprvdSavers
' Note! This cannot have an error handler
' Example: Select Case DspErrMsg(cModule & "." & cRoutine)
' Case Is = vbAbort: Stop: Resume 'Debug mode - Trace
' Case Is = vbRetry: Resume 'Try again
' Case Is = vbIgnore: 'End routine
' End Select
' Date Ini Modification
' 11/08/11 CWH Initial Programming
' 11/17/11 CWH Made it always in debugmode if I'm the user
' 02/16/12 CWH Removed "Help" button for err.number 999
' 04/07/12 CWH Leveraged Constant AprvdSavers
' 04/18/12 CWH Add AddText
' Declarations
Const DebugMode As Boolean = False 'True forces routines to stop on error
Dim sHelpFile As String
Dim lHelpContext As Long
' Procedure
sHelpFile = Err.HelpFile
lHelpContext = Err.HelpContext
DspErrMsg = MsgBox( _
"Error#" & Err.Number & vbLf & Err.Description & vbLf & sAddText, _
IIf(DebugMode Or InStr(1, AprvdSavers, Environ("UserName"), vbTextCompare) > 0, _
vbAbortRetryIgnore, vbCritical) + IIf(Err.Number = 999, 0, vbMsgBoxHelpButton), _
cRoutineName, _
sHelpFile, _
lHelpContext)
End Function
Public Function GetUser()
GetUser = Environ("USERNAME")
End Function
Public Function GetDepCode(user As String) As Integer
Dim frm As frmDepartment
Set frm = New frmDepartment
frm.show 1
If frm.m_Ok Then
GetDepCode = frm.m_ItemData
End If
Unload frm
Set frm = Nothing
End Function
Public Sub SaveMySetting(Section As String, Key As String, Value As String)
Call SaveSetting(AppName, Section, Key, Value)
End Sub
Public Function GetMySetting(Section As String, Key As String)
GetMySetting = GetSetting(AppName, Section, Key, "")
End Function
Public Sub ClearControls(frm As UserForm)
'On Error Resume Next
On Error GoTo LocalErr
Dim ctl As MSForms.Control
Dim strTag As String
For Each ctl In frm.Controls
strTag = ""
If ctl.Tag <> "" Then
strTag = GetToken(ctl.Tag, 2)
If strTag = "True" Then
'If TypeOf ctl Is TextBox Then
If TypeName(ctl) = "TextBox" Then
ctl.Text = ""
ElseIf TypeName(ctl) = "CheckBox" Or TypeName(ctl) = "OptionButton" Or TypeName(ctl) = "ToggleButton" Then
ctl.Value = False
ElseIf TypeName(ctl) = "ComboBox" Or TypeName(ctl) = "ListBox" Then
'If ctl.style <> 2 Then
' ctl.Text = ""
'End If
ctl.Clear
'ctl.ListIndex = -1
End If
End If
End If
Next
Exit Sub
LocalErr:
MsgBox "Error [" & ctl.Name & "] " & Err.Description
End Sub
Function GetToken(ByVal strVal As String, intIndex As Integer, Optional strDelimiter As String = ";") As String
Dim strSubString() As String
Dim intIndex2 As Integer
Dim i As Integer
Dim intDelimitLen As Integer
If strVal = "" Then Exit Function
'strDelimiter = ";" 'Change this accordingly
intIndex2 = 1
i = 0
intDelimitLen = Len(strDelimiter)
Do While intIndex2 > 0
ReDim Preserve strSubString(i + 1)
intIndex2 = InStr(1, strVal, strDelimiter)
If intIndex2 > 0 Then
strSubString(i) = Mid(strVal, 1, (intIndex2 - 1))
strVal = Mid(strVal, (intIndex2 + intDelimitLen), Len(strVal))
Else
strSubString(i) = strVal
End If
i = i + 1
Loop
If intIndex > (i + 1) Or intIndex < 1 Then
GetToken = ""
Else
GetToken = strSubString(intIndex - 1)
End If
End Function
Public Function WhereInArray(arr1 As Variant, vFind As Variant) As Variant
'DESCRIPTION: Function to check where a value is in an array
Dim i As Long
For i = LBound(arr1) To UBound(arr1)
If arr1(i) = vFind Then
WhereInArray = i
Exit Function
End If
Next i
'if you get here, vFind was not in the array. Set to null
WhereInArray = Null
End Function
Public Function LoadLineCombo(ByRef coll As cComboCollection, ByRef cmbControl As MSForms.ComboBox, lngDepID As Long)
On Error GoTo LocalErr
Dim oLine As New LineTable
Dim rs As ADODB.Recordset
Set rs = oLine.LoadList(lngDepID)
If oLine.ErrorDesc <> "" Then
MsgBox oLine.ErrorDesc
LoadLineCombo = -1
Exit Function
End If
If IsValiD(rs) Then
Do While Not rs.EOF
With coll
.AddItem CStr(rs!LineText), CLng(rs!LineID)
End With
rs.MoveNext
Loop
cmbControl.Enabled = True
Else
cmbControl.Enabled = False
End If
Set rs = Nothing
Set oLine = Nothing
LoadLineCombo = 0
Exit Function
LocalErr:
LoadLineCombo = Err.Number
End Function
Public Function LoadShiftCombo(ByRef coll As cComboCollection, ByRef cmbControl As MSForms.ComboBox, lngDepID As Long)
On Error GoTo LocalErr
Dim oShift As New Shifts
Dim rs As ADODB.Recordset
'If cmbDepartment.ListIndex <> -1 Then
Set rs = oShift.LoadList(lngDepID)
'Else
'End If
If oShift.ErrorDesc <> "" Then
MsgBox oShift.ErrorDesc
LoadShiftCombo = -1
Exit Function
End If
'cmbControl.Clear
' ID = 0
If IsValiD(rs) Then
Do While Not rs.EOF
With coll
.AddItem CStr(rs!ShiftName), CLng(rs!ShiftID)
End With
rs.MoveNext
Loop
cmbControl.Enabled = True
Else
cmbControl.Enabled = False
End If
Set rs = Nothing
Set oShift = Nothing
LoadShiftCombo = 0
Exit Function
LocalErr:
LoadShiftCombo = Err.Number
End Function
Public Function LoadBatchQtyCombo(ByRef coll As cComboCollection, ByRef cmbControl As MSForms.ComboBox, lngDepID As Long)
On Error GoTo LocalErr
Dim oUOM As New UOMTable
Dim rs As ADODB.Recordset
'If cmbDepartment.ListIndex <> -1 Then
Set rs = oUOM.LoadList(lngDepID)
'Else
'End If
If oUOM.ErrorDesc <> "" Then
MsgBox oUOM.ErrorDesc
LoadBatchQtyCombo = -1
Exit Function
End If
If IsValiD(rs) Then
Do While Not rs.EOF
With coll
.AddItem CStr(rs!UomCount) & "/" & CStr(rs!UomText), CLng(rs!UomID)
End With
rs.MoveNext
Loop
cmbControl.Enabled = True
Else
cmbControl.Enabled = False
End If
Set rs = Nothing
Set oUOM = Nothing
LoadBatchQtyCombo = 0
Exit Function
LocalErr:
LoadBatchQtyCombo = Err.Number
End Function
Public Function LoadProductModel(ByRef coll As cComboCollection, ByRef cmbControl As MSForms.ComboBox, lngDepID As Long)
On Error GoTo LocalErr
Dim oProductModel As New ProductModel
Dim rs As ADODB.Recordset
'If cmbDepartment.ListIndex <> -1 Then
Set rs = oProductModel.LoadList(lngDepID)
'Else
'End If
If oProductModel.ErrorDesc <> "" Then
MsgBox oProductModel.ErrorDesc
LoadProductModel = -1
Exit Function
End If
If IsValiD(rs) Then
Do While Not rs.EOF
With coll
.AddItem CStr(rs!Description), CLng(rs!ID)
End With
rs.MoveNext
Loop
cmbControl.Enabled = True
Else
cmbControl.Enabled = False
End If
Set rs = Nothing
Set oProductModel = Nothing
LoadProductModel = 0
Exit Function
LocalErr:
LoadProductModel = Err.Number
End Function
Public Function LoadStatusCode(ByRef coll As cComboCollection, ByRef cmbControl As MSForms.ComboBox, lngDepID As Long)
On Error GoTo LocalErr
Dim oStatus As New StatusCode
Dim rs As ADODB.Recordset
'If cmbDepartment.ListIndex <> -1 Then
Set rs = oStatus.LoadList()
'Else
'End If
If oStatus.ErrorDesc <> "" Then
MsgBox oStatus.ErrorDesc
LoadStatusCode = -1
Exit Function
End If
If IsValiD(rs) Then
Do While Not rs.EOF
With coll
.AddItem CStr(rs!StatusText), CLng(rs!StatusID)
End With
rs.MoveNext
Loop
cmbControl.Enabled = True
Else
cmbControl.Enabled = False
End If
Set rs = Nothing
Set oStatus = Nothing
LoadStatusCode = 0
Exit Function
LocalErr:
LoadStatusCode = Err.Number
End Function
' "Exists" Functions with Functions
Public Function Exists(ByVal vCollection As Variant, _
ByVal sName As String, _
Optional ByRef vItem As Variant) As Boolean
' Description:Determine if a name exists in a collection
' Inputs: vCollection Collection to check
' sName Collection Item's Name
' vItem Variable to hold collection instance
' Outputs: Me Success/Failure
' Requisites: *None
' Example: ?Exists(Worksheets, "UsrCodes")
' ?Exists(ActiveWorkbook.Names, "WBS", vItem)
' ?Exists(ThisWorkbook.Styles, "Bad", vItem)
' ?Exists(Workbooks(2).TableStyles, "TableStyleMedium14", vItem)
' ?Exists(ActiveSheet.Shapes, "Button", vItem)
' ?Exists(Array("Input", "Bad", "Good", "Neutral"), Selection.Style.Name)
' Date Ini Modification
' 06/25/01 CWH Initial Programming
' 08/01/13 CWH Test for Blank Item
' 10/22/13 CWH Covered oCollection not set
' 12/04/15 CWH Now handles arrays
' Declarations
Const cRoutine As String = "Exists"
Dim v As Variant
' Error Handling Initialization
On Error GoTo ErrHandler
Exists = False
' Procedure
Select Case TypeName(vCollection)
Case Is = "Range"
Set vItem = vCollection.Find(What:=sName, _
LookIn:=xlValues, _
LookAt:=xlWhole)
If vItem Is Nothing Then Err.Raise 5
Exists = True
Case Is = "Variant()", "String()"
For Each v In vCollection
If CStr(v) = sName Then
vItem = v
Exists = True
Exit For
End If
Next
Case Else
If IsObject(vCollection) Then
Set vItem = vCollection(sName)
Exists = True
End If
End Select
ErrHandler:
Select Case Err.Number
Case Is = NoError: 'Do nothing
Case Is = 5, 9, 13, 91, 1004, 3265, -2147024809 'Do Nothing (not found)
Case Else:
Select Case DspErrMsg(cModule & "." & cRoutine)
Case Is = vbAbort: Stop: Resume 'Debug mode - Trace
Case Is = vbRetry: Resume 'Try again
Case Is = vbIgnore: 'End routine
End Select
End Select
End Function
Public Sub ArrayRemoveItem(ItemArray As Variant, ByVal ItemElement As Long)
'PURPOSE: Remove an item from an array, then
' resize the array
'PARAMETERS: ItemArray: Array, passed by reference, with
' item to be removed. Array must not be fixed
' ItemElement: Element to Remove
'EXAMPLE:
' dim iCtr as integer
' Dim sTest() As String
' ReDim sTest(2) As String
' sTest(0) = "Hello"
' sTest(1) = "World"
' sTest(2) = "!"
' ArrayRemoveItem sTest, 1
' for iCtr = 0 to ubound(sTest)
' Debug.print sTest(ictr)
' next
'
' Prints
'
' "Hello"
' "!"
' To the Debug Window
Dim lCtr As Long
Dim lTop As Long
Dim lBottom As Long
If Not IsArray(ItemArray) Then
Err.Raise 13, , "Type Mismatch"
Exit Sub
End If
lTop = UBound(ItemArray)
lBottom = LBound(ItemArray)
If ItemElement < lBottom Or ItemElement > lTop Then
Err.Raise 9, , "Subscript out of Range"
Exit Sub
End If
For lCtr = ItemElement To lTop - 1
ItemArray(lCtr) = ItemArray(lCtr + 1)
Next
On Error GoTo ErrorHandler:
ReDim Preserve ItemArray(lBottom To lTop - 1)
Exit Sub
ErrorHandler:
'An error will occur if array is fixed
Err.Raise Err.Number, , _
"You must pass a resizable array to this function"
End Sub
Function rpad(ByVal p_string As String, ByVal p_count As Integer, Optional ByVal p_character As String)
Dim v_character As String * 1
Dim v_count As Integer
If (p_count > 0) Then
v_count = p_count
Else
v_count = 0
End If
If (Len(p_string) >= v_count) Then
rpad = p_string
Exit Function
End If
If (Not IsMissing(p_character)) Then
v_character = p_character
Else
v_character = " "
End If
rpad = Left(p_string + String(v_count, v_character), v_count)
End Function
Function lpad(ByVal p_string As String, ByVal p_count As Integer, Optional ByVal p_character As String)
Dim v_character As String * 1
Dim v_count As Integer
If (p_count > 0) Then
v_count = p_count
Else
v_count = 0
End If
If (Len(p_string) >= v_count) Then
lpad = p_string
Exit Function
End If
If (Not IsMissing(p_character)) Then
v_character = Left(p_character, 1)
Else
v_character = " "
End If
lpad = Right(String(v_count, v_character) + p_string, v_count)
End Function
Public Sub CreateWorkSheet()
Dim wsheet As Worksheet
Dim a As Variant
Dim ws_num As Integer
Dim iCol, FldCount As Integer
Dim rs As ADODB.Recordset
'ws_num = ThisWorkbook.Worksheets.Count
' create actual workbook and use first worksheet
Set wsheet = Workbooks.Add.Worksheets(1)
'Set wsheet = ActiveSheet 'remember which worksheet is active in the beginning
'Format as necessary
'wsheet("Sheet1").Range("A17").NumberFormat = "General"
'wsheet("Sheet1").Rows(1).NumberFormat = "hh:mm:ss"
'wsheet("Sheet1").Columns("C"). _
'NumberFormat = "$#,##0.00_);[Red]($#,##0.00)"
With wsheet
' Clear the data in output worksheet
.Cells.ClearContents
' Set the cell formats
.Columns(2).NumberFormat = "dd/mm/yyyy"
.Columns(3).NumberFormat = "$#,##0;[Red]$#,##0"
.Columns(4).NumberFormat = "0"
.Columns(5).NumberFormat = "$#,##0;[Red]$#,##0"
End With
' Copy field names to the first row of the worksheet
FldCount = rs.Fields.Count
For iCol = 1 To FldCount
wsheet.Cells(1, iCol).Value = rs.Fields(iCol - 1).Name
Next
'For iCol = 0 To rs.Fields.Count - 1
' wsheet.Cells(1, i + 1).Value2 = rs.Fields(i).Name
'Next i
' Copy the recordset to the worksheet, starting in cell A2
wsheet.Cells(2, 1).CopyFromRecordset rs
'wsheet.Range("A2").CopyFromRecordset rs
'Note: CopyFromRecordset will fail if the recordset
'contains an OLE object field or array data such
'as hierarchical recordsets
'a = ActiveSheet.Range("A1").Value
'wsheet.Range("A1").Value = a
' close and clear from memory
' Auto-fit the column widths and row heights
wsheet.Columns.AutoFit
wsheet.Rows.AutoFit
wsheet.Parent.Close False
Set wsheet = Nothing
End Sub
Sub AddRefByGUID(strGUID As String, lngMaj As Long, lngMin As Long)
On Error GoTo LocalErr
'Call Application.VBE.activeVBProject.references.addFromGuid("{0E59F1D2-1FBE-11D0-8FF2-00A0D10038BC}", 1, 0)
Dim ref
Call Application.VBE.activeVBProject.References.AddFromGuid("{0ECD9B60-23AA-11D0-B351-00A0C9055D8E}", 6, 0)
'Call Application.VBE.activeVBProject.References.AddFromGuid(Chr(34) & strGUID & Chr(34), lngMaj, lngMin)
Exit Sub
LocalErr:
MsgBox "Error setting reference to " & strGUID & " " & Err.Description
End Sub
Sub GetRef()
'After referencing 'Microsoft Visual Basic for Applications Extensibility 5.3' you can:
Dim my_ref As VBIDE.Reference
For Each my_ref In ThisWorkbook.VBProject.References
With my_ref
Debug.Print .Name, .Description, .FullPath, .IsBroken
Debug.Print
End With
Next
End Sub
Public Sub PrintToPDF()
Dim tFile As Variant
Dim tPathIn As String
Dim tPathOut As String
Dim tNewName As String
Dim tSingleWord As Range
tPathIn = " … "
tPathOut = " … "
'tFile = Dir(tPathIn & "*.txt")
'Do While tFile <> ""
Documents.Open filename:=tPathIn & tFile
With ActiveDocument
With .PageSetup
.LeftMargin = InchesToPoints(0.5)
.RightMargin = InchesToPoints(0.5)
End With
tNewName = "pnp" & Mid(.Name, 18, 4) & Mid(.Name, 14, 4)
With .Sections.item(1).Headers(wdHeaderFooterPrimary).Range
.Text = ActiveDocument.Name
.Paragraphs.Alignment = wdAlignParagraphCenter
.Font.Name = "Consolas"
End With
For Each tSingleWord In .Words
If tSingleWord.Font.Name <> "Consolas" Then
tSingleWord.Font.Name = "Consolas"
tSingleWord.Font.Size = 11
End If
Next
.ExportAsFixedFormat OutputFileName:=tPathOut & tNewName & ".pdf", ExportFormat:=wdExportFormatPDF
Word.ActiveDocument.Saved = True
.Close
End With
' tFile = Dir
'Loop
End Sub
Public Function GetTempFolder() As String
GetTempFolder = Environ("Temp")
End Function
Public Function GetTempFilename() As String
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
GetTempFilename = fso.GetTempName() 'Result: "rad65800.tmp"
Set fso = Nothing
End Function
Share This
