VB script in Excel prints with a preview? 1

CraigHappy · Aug 3, 2006

Hi

I'm not sure if I'm in the correct section for my VB problem or not, but here goes -

I have a friends invoicing program with runs through Excel, I know nothing about VB and all seems to be ok with the program except if the regedit 'Develop' section is set to a value of 1, when printing it goes to a preview first, which he doesn't want, if I change it to 0, I get no preview and it prints off straight away the two copies, but it shows Excels headers, which he doesn't want shown.

The script was created by a firend, but no longer has support, if anyone thinks they can sort this simple thing out for me, please let me know and I'll PM the files across.

Many thanks, Craig.

markdmac · Aug 6, 2006

Post the script if you wish to have us help troubleshoot it. Also post the full registry path to the key you are referencing so it can be tested.

I hope you find this post helpful.

Regards,

Mark

Check out my scripting solutions at

http://www.thespidersparlor.com/vbscript

CraigHappy · Aug 6, 2006

Hi,

Please find below two parts of the script, there are more parts, but I think these are the two that the problem relates to, as the others do different things.

This part was in -
VBAProject(willinghammotorsinvoice.xls) - modules - modMain

Code:

Option Explicit

Public VATRate
Global UpdateIt As Boolean
Global DevelopIt As Boolean
Global CarSale As Boolean
Global CarInvoice As String
Global InvoiceNo As Long
Global InvoiceNumber As Variant

Public Const MyCommandBarName As String = "InvoiceProgram"
Public Const MyPassword As String = "soots"
Public Const InvNoCell = "J6"
Public Const SettingName = "Connect-2"
Public Const WorksheetName = "Invoice"
'Public Const TheSerial = "E45B-BFA6-68AA-8191-5421"

Sub DeleteMyCommandBar()
    On Error Resume Next
    Application.CommandBars(MyCommandBarName).Delete
    On Error GoTo 0
End Sub

Sub CreateMyCommandBar()
Dim cb As CommandBar, CopyAndPasteMenu As CommandBar
Dim Copy As CommandBarButton, Paste As CommandBarButton

     DeleteMyCommandBar ' in case it already exists
  
    ' Create a new temporary commandbar
    Set cb = CommandBars.Add(MyCommandBarName, msoBarTop, True, True)

    With cb
        .Visible = True
        .Left = 0
        .Top = 0
    End With
    
    AddToFile cb
    AddToGoTo cb
    AddToHelp cb
    Set cb = Nothing

End Sub
Private Sub AddToFile(cb As CommandBar)
Dim M As CommandBarPopup, mi As CommandBarButton
    
    If cb Is Nothing Then Exit Sub
    Set M = cb.Controls.Add(msoControlPopup, , , , True)
    With M
        .BeginGroup = False
        .Caption = "&File"
        .TooltipText = "MenuDescriptionText"
    End With
    
    Set mi = M.Controls.Add(msoControlButton, , , , True)
    With mi
        .Caption = "E&xit"
        .OnAction = "MyQuit"
        .Style = msoButtonCaption
    End With
    
    Set mi = Nothing
    Set M = Nothing
    
End Sub
Private Sub AddToGoTo(cb As CommandBar)
Dim M As CommandBarPopup, mi As CommandBarButton
    
    If cb Is Nothing Then Exit Sub
    Set M = cb.Controls.Add(msoControlPopup, , , , True)
    With M
        .BeginGroup = False
        .Caption = "&Go To"
        .TooltipText = "MenuDescriptionText"
    End With
    
    Set mi = M.Controls.Add(msoControlButton, , , , True)
    With mi
        .Caption = "Index"
        .OnAction = "MyIndex"
        .Style = msoButtonCaption
    End With
    
    Set mi = M.Controls.Add(msoControlButton, , , , True)
    With mi
        .Caption = "Invoice"
        .BeginGroup = True
        .OnAction = "MyInvoice"
        .Tag = "Invoice"
        .Style = msoButtonCaption
    End With
    
    Set mi = M.Controls.Add(msoControlButton, , , , True)
    With mi
        .Caption = "Car Sale Invoice"
        .OnAction = "MyCarInvoice"
        .Tag = "CarInvoice"
        .Style = msoButtonCaption
    End With
    
    Set mi = M.Controls.Add(msoControlButton, , , , True)
    With mi
        .Caption = "Part Description"
        .BeginGroup = True
        .OnAction = "MyParts"
        .Style = msoButtonCaption
    End With
    
    Set mi = M.Controls.Add(msoControlButton, , , , True)
    With mi
        .Caption = "Work Descriptions"
        .OnAction = "MyWork"
        .Style = msoButtonCaption
    End With
    
    Set mi = M.Controls.Add(msoControlButton, , , , True)
    With mi
        .Caption = "Car Sale Descriptions"
        .OnAction = "MyCarDesc"
        .Style = msoButtonCaption
    End With
    
    Set mi = M.Controls.Add(msoControlButton, , , , True)
    With mi
        .Caption = "History"
        .BeginGroup = True
        .OnAction = "MyHistory"
        .Style = msoButtonCaption
    End With
    
    Set mi = Nothing
    Set M = Nothing
End Sub


Private Sub AddToHelp(cb As CommandBar)
' adds a menu to a commandbar, duplicate this procedure for each menu you want to create
Dim M As CommandBarPopup, mi As CommandBarButton
    If cb Is Nothing Then Exit Sub
    ' create the menu
    Set M = cb.Controls.Add(msoControlPopup, , , , True)
    With M
        .BeginGroup = False
        .Caption = "&Help"
        .TooltipText = "MenuDescriptionText"
    End With
    
    ' add a menu item
    Set mi = M.Controls.Add(msoControlButton, , , , True)
    With mi
        .Caption = "About"
        .OnAction = "MySplash()"
        .Style = msoButtonCaption
    End With
    Set mi = Nothing
    Set M = Nothing
    
End Sub
Sub MySplash() ' dummy macro for the example commandbar
 '   frmSplash.Show
End Sub
Public Sub MyInvoice()
Dim M As CommandBarPopup, mi As CommandBarButton
    
CarSale = False
Application.GoTo Reference:=Worksheets("Invoice").Range("C10")
ActiveWindow.DisplayVerticalScrollBar = True

Set mi = Nothing
Set M = Nothing

End Sub
Public Sub MyCarInvoice()
Dim M As CommandBarPopup, mi As CommandBarButton
    
CarSale = True
Application.GoTo Reference:=Worksheets("Invoice").Range("C10")
ActiveWindow.DisplayVerticalScrollBar = True

Set mi = Nothing
Set M = Nothing

End Sub
Public Sub MyIndex()
    Application.GoTo Reference:=Worksheets("Index").Range("F6")
    ActiveWindow.DisplayVerticalScrollBar = False
End Sub
Public Sub MyParts()
    GoToDesc ("Parts")
End Sub
Public Sub MyWork()
    GoToDesc ("Description")
End Sub
Public Sub MyCarDesc()
    GoToDesc ("CarSalesDescription")
End Sub
Public Sub MyHistory()
    Application.GoTo Reference:=Worksheets("ServiceHistory").Range("C5")
    ActiveWindow.DisplayVerticalScrollBar = True
End Sub
Public Function WorkbookOpen(WorkbookName As String) As Boolean

WorkbookOpen = False
On Error GoTo WorkbookNotOpen
If Len(Application.Workbooks(WorkbookName).Name) > 0 Then
    WorkbookOpen = True
    Application.Calculation = xlCalculationManual
    Exit Function
End If

WorkbookNotOpen:

End Function
Public Sub MyQuit()
    MainQuit
End Sub

Public Sub PartsMove()
Dim r As Long, c As Range

Application.ScreenUpdating = False

' Move the headers down one row, if row 2 says Description
If Application.Worksheets("Parts").Range("B2").Value = "Description of Parts Used" Then
    ' Remove protection for editing
    Application.Worksheets("Parts").Protect Password:="", _
        DrawingObjects:=False, contents:=False
        
    Set c = Application.Worksheets("Parts").Range("B2")
    With c
        .Font.Name = "Arial"
        .Font.Size = 11
        .Font.Bold = True
        .Font.Italic = False
        .Font.Underline = True
        .VerticalAlignment = xlVAlignCenter
        .HorizontalAlignment = xlHAlignCenter
        .Value = "Description of Parts Used"
    End With
    Application.Worksheets("Parts").Range("B1").Value = ""
    'Set c = Application.Worksheets("Parts").Range("C2")
    'With c
    '    .Font.Name = "Arial"
    '    .Font.Size = 11
    '    .Font.Bold = True
    '    .Font.Italic = False
    '    .Font.Underline = True
    '    .VerticalAlignment = xlVAlignCenter
    '    .HorizontalAlignment = xlHAlignCenter
    '    .Value = "To History"
    'End With
    'Application.Worksheets("Parts").Range("C1").Value = ""
End If

' Find row number after last used row
r = Application.Worksheets("Parts").Range("B65536").End(xlUp).Row + 1
'Application.Goto Reference:=Worksheets("Parts").Range("B" & r)
ActiveWindow.DisplayVerticalScrollBar = True
Application.ScreenUpdating = True

End Sub

Public Function FormLoadedVBA(sFormName As String) As Boolean
    Dim lForm As Long

    For lForm = 0 To UserForms.Count - 1
        If UserForms(lForm).Name = sFormName Then
            FormLoadedVBA = True
            Exit For
        End If
    Next
    
End Function
Public Sub GoToDesc(xSheet As String)
Dim r As Long, c As Range

' Remove protection for editing
Application.Worksheets(xSheet).Protect Password:="", _
        DrawingObjects:=False, contents:=False

' Move the headers down one row
Set c = Application.Worksheets(xSheet).Range("B2")
With c
    .Font.Name = "Arial"
    .Font.Size = 11
    .Font.Bold = True
    .Font.Italic = False
    .Font.Underline = True
    .VerticalAlignment = xlVAlignCenter
    .HorizontalAlignment = xlHAlignCenter
    .Value = IIf(xSheet = "CarSalesDescription", "Car Sale Descriptions Used", "Description of Descriptions Used")
End With
Application.Worksheets(xSheet).Range("B1").Value = ""

' Find row number after last used row
r = Application.Worksheets(xSheet).Range("B65536").End(xlUp).Row + 1
Application.GoTo Reference:=Worksheets(xSheet).Range("B" & r)
ActiveWindow.DisplayVerticalScrollBar = True

End Sub
Public Sub MainQuit()
Dim w As Workbook, x As Long, bar As CommandBar

Application.ScreenUpdating = False
Application.Worksheets("Invoice").Unprotect Password:=MyPassword
For Each bar In Application.CommandBars
    If bar.BuiltIn And Not bar.Enabled Then bar.Enabled = True
Next
    
DeleteMyCommandBar
Application.DisplayFormulaBar = True

' We have to clear all the fields in the invoice sheet
' ready for next time.
Application.EnableEvents = False
With Application.Worksheets("Invoice")
    .Range("K6").Value = ""    ' Your Ref
    .Range("C10").Value = ""    ' Address
    .Range("C11").Value = ""    ' Address1
    .Range("C12").Value = ""    ' Address2
    .Range("H12").Value = ""    ' Tel No
    .Range("D15").Value = ""    ' Make
    .Range("F15").Value = ""    ' Model
    .Range("H15").Value = ""    ' Reg
    .Range("J15").Value = ""    ' Mileage
    .Range("C39.K39").Value = ""    ' Non VAT Line
    For x = 17 To 36
        .Range("C" & x & ".K" & x).Value = ""
        .Range("C" & x & ".K" & x).RowHeight = 18.75
    Next x
'    .Protect Password:=MyPassword
End With
Application.EnableEvents = True
Application.ScreenUpdating = True

' Up the Invoice number by 1 if the invoice was printed
If GetSetting(SettingName, "Print", "HasPrinted") = 1 Then
    If CarSale Then
        SaveSetting SettingName, WorksheetName, "CarInvoiceNumber", CarInvoice + 1
    Else
        SaveSetting SettingName, WorksheetName, "InvoiceNumber", InvoiceNo + 1
    End If
    SaveSetting SettingName, "Print", "HasPrinted", 0   ' Set to false
End If

' Now close everything
Application.DisplayAlerts = False
For Each w In Application.Workbooks
    w.Save
Next w
Application.Calculation = xlCalculationAutomatic
Application.Quit

End Sub
Public Function PadLeftString(xString As String, xPad As String, xLen As Long)

PadLeftString = String(xLen - Len(xString), xPad) & xString

End Function

and this part is in -
VBAProject(willinghammotorsinvoice.xls) - Microsoft Excel Objects - Sheets2 (Invoice)

Code:

Option Explicit

Private Sub Worksheet_Activate()

Application.Worksheets("Invoice").Protect Password:=MyPassword, UserInterfaceOnly:=True
Application.ScreenUpdating = False

Me.Range(InvNoCell).Value = IIf(CarSale, CarInvoice, InvoiceNo)
If CarSale Then
    Me.Range("J4").Value = "Car Sales Invoice"
    Me.Range("J4").Font.Size = 22
    Me.Range("J4").Font.Color = 9868950 ' Light grey
    Me.Range("J38").Value = ""
    Me.cmdParts.Visible = False
    Me.cmdAddParts.Visible = False
    Me.cmdGoToDesc.Caption = "Go To Car Sales Descriptions"
    Me.cmdGoToDesc.Height = Me.cmdGoToDesc.Height + 10
    Me.cmdAddDesc.Caption = "Add Car Sale Description"
Else
    Me.Range("J4").Value = "Invoice"
    Me.Range("J4").Font.Size = 24
    Me.Range("J4").Font.Color = 9868950
    Me.Range("J38").Value = "VAT"
    Me.cmdParts.Visible = True
    Me.cmdAddParts.Visible = True
    Me.cmdGoToDesc.Caption = "Go To Descriptions"
    Me.cmdGoToDesc.Height = 39
    Me.cmdAddDesc.Caption = "Add Descriptions"
End If
Me.Range("J8").Value = Format(Date, "d MMM yyyy")
Application.ScreenUpdating = True

End Sub
Private Sub chkBoxKilos_Click()
chkBoxMiles.Value = IIf(Me.chkBoxKilos.Value = True, False, True)
End Sub

Private Sub chkBoxMiles_Click()
chkBoxKilos.Value = IIf(Me.chkBoxMiles.Value = True, False, True)
End Sub
Private Sub cmdReset_Click()
Dim ans As Variant, InvoiceNumber As Variant
Dim temp As Long

If CarSale Then
    temp = Replace(Me.Range(InvNoCell).Value, "/", "")
    ans = InputBox("This will reset the 'Car Sale' Invoice No. The current number is " & _
        temp & "." & vbCrLf & "Enter the new number or click 'Cancel'. Do not enter the / the computer " & _
        "will do this for you.", "Car Sale Invoice No Reset", , 5500, 3500)
    If ans = "" Then Exit Sub
Else
    ans = InputBox("This will reset the Invoice No. The current number is " & _
        CStr(Me.Range(InvNoCell).Value) & "." & vbCrLf & _
        "Enter the new number or click 'Cancel'.", "Invoice No Reset", , 5500, 3500)
    If ans = "" Then Exit Sub
End If
InvoiceNumber = ans

If CarSale Then
    SaveSetting SettingName, WorksheetName, "CarInvoiceNumber", InvoiceNumber
    CarInvoice = CStr(Year(Date)) - 2000 & "/" & _
            Mid(InvoiceNumber, IIf(Len(InvoiceNumber) = 5, 2, 3))
Else
    SaveSetting SettingName, WorksheetName, "InvoiceNumber", InvoiceNumber
    InvoiceNo = InvoiceNumber
End If
Me.Range(InvNoCell).Value = IIf(CarSale, CarInvoice, InvoiceNo)

End Sub
Private Sub cmdAddDesc_Click()
frmDescription.Show
End Sub

Private Sub cmdAddParts_Click()
frmParts.Show
End Sub
Private Sub cmdGoToDesc_Click()

If CarSale Then
    GoToDesc "CarSalesDescription"
Else
    GoToDesc "Description"
End If

End Sub

Private Sub cmdParts_Click()
Dim r As Long, c As Range

' Remove protection for editing
Application.Worksheets("Parts").Protect Password:="", _
        DrawingObjects:=False, contents:=False

' Move the headers down one row
Set c = Application.Worksheets("Parts").Range("B2")
With c
    .Font.Name = "Arial"
    .Font.Size = 11
    .Font.Bold = True
    .Font.Italic = False
    .Font.Underline = True
    .VerticalAlignment = xlVAlignCenter
    .HorizontalAlignment = xlHAlignCenter
    .Value = "Description of Parts Used"
End With
Application.Worksheets("Parts").Range("B1").Value = ""

' Find row number after last used row
r = Application.Worksheets("Parts").Range("B65536").End(xlUp).Row + 1
Application.GoTo Reference:=Worksheets("Parts").Range("B" & r)

ActiveWindow.DisplayVerticalScrollBar = True

End Sub

Private Sub cmdIndex_Click()

'CarSale = False
Me.chkBoxKilos.Value = False
Me.chkBoxMiles.Value = True
Application.GoTo Reference:=Worksheets("Index").Range("F6")
ActiveWindow.DisplayVerticalScrollBar = False

End Sub

Private Sub cmdNew_Click()
Dim x As Long, ans As Variant

'Application.Worksheets("Invoice").Unprotect Password:=MyPassword

Application.ScreenUpdating = False

If GetSetting(SettingName, "Print", "HasPrinted") = 0 Then
    ans = MsgBox("You haven't printed this invoice! Are you sure you want a new one?", _
            vbExclamation + vbYesNo, "Confirmation")
    If ans = vbNo Then Exit Sub
End If
SaveSetting SettingName, "Print", "HasPrinted", 0   ' Set to false

ans = MsgBox("Is the new invoice for a Car Sale?", vbQuestion + vbYesNoCancel, "Invoice Type")
CarSale = IIf(ans = vbYes, True, False)
UpInvoice

Select Case ans
Case vbYes, vbNo
    CarInvoice = GetSetting(SettingName, WorksheetName, "CarInvoiceNumber")
    InvoiceNumber = GetSetting(SettingName, WorksheetName, "InvoiceNumber")
Case Else
    Exit Sub
End Select
Application.EnableEvents = False

If CarSale Then
    Me.Range("J4").Value = "Car Sales Invoice"
    Me.Range("J4").Font.Size = 22
    Me.Range("J4").Font.Color = 9868950 ' Light grey
    Me.Range("J38").Value = ""
    Me.cmdParts.Visible = False
    Me.cmdAddParts.Visible = False
    Me.cmdGoToDesc.Caption = "Go To Car Sales Descriptions"
    Me.cmdGoToDesc.Height = Me.cmdGoToDesc.Height + 10
    Me.cmdAddDesc.Caption = "Add Car Sale Description"
Else
    Me.Range("J4").Value = "Invoice"
    Me.Range("J4").Font.Size = 24
    Me.Range("J4").Font.Color = 9868950
    Me.Range("J38").Value = "VAT"
    Me.cmdParts.Visible = True
    Me.cmdAddParts.Visible = True
    Me.cmdGoToDesc.Caption = "Go To Descriptions"
    Me.cmdGoToDesc.Height = 39
    Me.cmdAddDesc.Caption = "Add Descriptions"
End If
Me.Range(InvNoCell).Value = CStr(IIf(CarSale, CarInvoice, InvoiceNo))

' We have to clear all the fields in the invoice sheet
' ready for next time.
Application.Worksheets("Invoice").Range("J9").Value = ""     ' Your Ref
Application.Worksheets("Invoice").Range("C10").Value = ""    ' Address
Application.Worksheets("Invoice").Range("C11").Value = ""    ' Address1
Application.Worksheets("Invoice").Range("C12").Value = ""    ' Address2
Application.Worksheets("Invoice").Range("H12").Value = ""    ' Tel No
Application.Worksheets("Invoice").Range("D15").Value = ""    ' Make
Application.Worksheets("Invoice").Range("F15").Value = ""    ' Model
Application.Worksheets("Invoice").Range("H15").Value = ""    ' Reg
Application.Worksheets("Invoice").Range("J15").Value = ""    ' Mileage
Application.Worksheets("Invoice").Range("K37").Value = ""    ' Sub-Total
Application.Worksheets("Invoice").Range("K38").Value = ""    ' VAT
Application.Worksheets("Invoice").Range("K40").Value = ""    ' Total
Application.Worksheets("Invoice").Range("C39.K39").Value = ""    ' Non VAT Line
For x = 17 To 36
    Application.Worksheets("Invoice").Range("C" & x & ".K" & x).Value = ""
    Application.Worksheets("Invoice").Range("C" & x & ".K" & x).RowHeight = 18.75
Next x
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Worksheets("Invoice").Protect Password:=MyPassword, UserInterfaceOnly:=True

End Sub

Private Sub cmdPrint_Click()
Dim WorksheetCell As String
Dim x As Long

'Application.Worksheets("Invoice").Unprotect Password:=MyPassword

' Print 2 copies, after first removing the borders, 1 with watermark and 1 without
For x = 17 To 35
    Me.Range("C" & x & ".L" & x).Borders(xlBottom).LineStyle = xlLineStyleNone
    Me.Range("C" & x & ".L" & x).Borders(xlTop).LineStyle = xlLineStyleNone
    ' Sometimes the left or right border goes missing, so put it back on here
    Me.Range("C" & x).Borders(xlLeft).LineStyle = xlContinuous
    Me.Range("L" & x).Borders(xlRight).LineStyle = xlContinuous
Next
Me.Range("C36.L36").Borders(xlTop).LineStyle = xlLineStyleNone

DevelopIt = GetSetting(SettingName, "Develop", "DevelopIt")

Application.ScreenUpdating = False
With ActiveSheet
    .Shapes("WordArt 34").Visible = False ' In case it got left on
    ' This is the watermark bit, don't print the watermark first time
    .Shapes("WordArt 34").Visible = False
    .PrintOut , , 1, DevelopIt
    ' Turn on watermark now
    .Shapes("WordArt 34").Visible = True
    .PrintOut , , 1, DevelopIt
    ' Turn it off again
    .Shapes("WordArt 34").Visible = False
End With
Application.ScreenUpdating = True

' Tell the registry we have printed
SaveSetting SettingName, "Print", "HasPrinted", 1   ' Set to true

' Now put the borders back on
For x = 17 To 35
    Me.Range("C" & x & ".L" & x).Borders(xlBottom).LineStyle = xlDash
Next
Me.Range("C36.L36").Borders(xlBottom).LineStyle = xlContinuous
Application.Worksheets("Invoice").Protect Password:=MyPassword, UserInterfaceOnly:=True

End Sub

Private Sub cmdQuit_Click()

Application.GoTo Reference:=Worksheets("Index").Range("F6")

End Sub

Private Sub cmdUpdateHistory_Click()
Dim xReg As String, xDate As Date, xMileage As Long, xInvoice As Long
Dim r As Long, xArray(21), x As Long, y As Long, xRow As Long
Dim xString As String, c As Variant, xAdd As String

UpdateIt = True

xReg = ActiveSheet.Range("H15")
xDate = ActiveSheet.Range("J8")
xMileage = ActiveSheet.Range("J15")
xInvoice = ActiveSheet.Range(InvNoCell)

' Need to load the array with all the work done
' on the invoice, if the Update History col is true
' and always do the first three lines.

y = 17 ' The row of the first workline

For x = 1 To UBound(xArray)
    xString = ActiveSheet.Range("C" & y)
    If xString <> "" Then
        ' Find in Parts sheet if after row 19
        ' otherwise just add
        If y < 20 Then
            xArray(x) = ActiveSheet.Range("C" & y).Value
        Else
            With Worksheets("Parts").Columns("B")
                Set c = .Find(xString)
            End With
            If Not c Is Nothing Then
                xAdd = "C" & Mid(c.Address, 4)
                If Worksheets("Parts").Range(xAdd) Then
                    xArray(x) = ActiveSheet.Range("C" & y).Value
                End If
            End If
        End If
    End If
    y = y + 1
Next x

' This is where the ServiceHistory sheet is updated
With Application.Worksheets("ServiceHistory")
    ' Find row number after last used row
    r = Application.Worksheets("ServiceHistory").Range("C65536").End(xlUp).Row + 1
    If r = 4 Then r = 5
    For x = 1 To UBound(xArray)
        If xArray(x) <> "" Then
            If Len(xArray(x)) <= 80 Then
                xRow = 20
            Else
                xRow = (Int(Len(xArray(x)) / 80) + 1) * 20
            End If
            .Range("C" & r).RowHeight = xRow
            ' Reg
            .Range("C" & r).Value = xReg
            .Range("C" & r).Font.Bold = True
            .Range("C" & r).Font.Color = vbBlack
            .Range("C" & r).VerticalAlignment = xlVAlignTop
            .Range("C" & r).HorizontalAlignment = xlHAlignCenter
            ' Date
            .Range("D" & r).Value = xDate
            .Range("D" & r).Font.Color = vbBlack
            .Range("D" & r).VerticalAlignment = xlVAlignTop
            .Range("D" & r).HorizontalAlignment = xlHAlignCenter
            ' Mileage
            If Me.chkBoxMiles Then
                .Range("E" & r).Value = xMileage
            Else
                .Range("E" & r).Value = xMileage & "Km"
            End If
            .Range("E" & r).Font.Color = vbBlack
            .Range("E" & r).VerticalAlignment = xlVAlignTop
            .Range("E" & r).HorizontalAlignment = xlHAlignCenter
            ' Invoice
            .Range("M" & r).Value = xInvoice
            .Range("M" & r).Font.Color = vbBlack
            .Range("M" & r).VerticalAlignment = xlVAlignTop
            .Range("M" & r).HorizontalAlignment = xlHAlignCenter
            ' Work
            .Range("F" & r).Value = xArray(x)
            .Range("F" & r).Font.Color = vbBlack
            .Range("F" & r).VerticalAlignment = xlVAlignTop
            .Range("F" & r).HorizontalAlignment = xlHAlignLeft
            ' Borders
            .Range("C" & r & ".M" & r).Borders(xlBottom).LineStyle = xlContinuous
            r = r + 1
        End If
    Next x
End With

UpdateIt = False

End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim WorksheetIndex As String
Dim xRow As Long, xStr As String

'Application.Worksheets("Invoice").Unprotect Password:=MyPassword
WorksheetIndex = "Index"

Application.EnableEvents = False
If Target.Address = "$D$15" Or Target.Address = "$F$15" Then
    Target = WorksheetFunction.Proper(Target)
    Application.EnableEvents = True
    Exit Sub
ElseIf Target.Address = "$H$15" Then
    Target = UCase(Replace(Target, " ", ""))
    Application.EnableEvents = True
    Exit Sub
End If

DoTotals Target

If Target.Row >= 17 And Target.Row <= 19 And Target.Column = 3 Then
    xStr = Left(Target.Address, 5)
    If Len(Range(xStr).Value) <= 92 Then
        xRow = 18.75
    Else
        xRow = (Int(Len(Range(xStr).Value) / 92) + 1) * 18.75
    End If
    ActiveSheet.Rows(Target.Row).RowHeight = xRow
End If

Application.EnableEvents = True
Application.Worksheets("Invoice").Protect Password:=MyPassword, UserInterfaceOnly:=True

End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If Target.Column <= 3 And Target.Row < 10 Or _
    Target.Column >= 13 Or _
    Target.Row >= 41 Or _
    Target.Address = "$J$4:$K$5" Or _
    Target.Address = "$J$7" Or _
    Target.Address = "$K$7" Or _
    (Target.Row <= 9 And Target.Column <= 9) Then
    ' Make sure the user stays within the confines of the invoice
    ActiveSheet.Range("C10").Select
    Exit Sub
End If
Select Case Target.Address
Case "$C$15"
    ActiveSheet.Range("D15").Select
Case "$E$15"
    ActiveSheet.Range("F15").Select
Case "$G$15"
    ActiveSheet.Range("H15").Select
Case "$I$15"
   ActiveSheet.Range("J15").Select
Case Else
    DoTotals Target
End Select

'Application.Worksheets("Invoice").Unprotect Password:=MyPassword
'Application.Worksheets("Invoice").Protect Password:=MyPassword, UserInterfaceOnly:=True

End Sub
Private Sub DoTotals(ByVal Target As Range)
Dim WorksheetIndex As String

WorksheetIndex = "Index"
'And Target.Column = 11

If ((Target.Row >= 17 And Target.Row <= 36) Or (Target.Row = 39)) Then
    With ActiveSheet
        .Range("K37").Value = WorksheetFunction.Sum(.Range("K17.K36"))
        If Not CarSale Then
            If VATRate = "" Then VATRate = GetSetting(SettingName, WorksheetIndex, "VATRate")
            ' If VATRate still not set then set it to 2002 value
            If VATRate = "" Then VATRate = 17.5
            .Range("K38").Value = .Range("K37").Value * VATRate / 100
        End If
        If UCase(Left(Range(Left(Target.Address, 5)).Value, 7)) = "PART-EX" Then
            .Range("K40").Value = .Range("K40").Value - .Range("K" & Target.Row).Value
            .Range("K" & Target.Row).Value = 1 - .Range("K" & Target.Row).Value
        End If
        .Range("K40").Value = WorksheetFunction.Sum(.Range("K37.K39"))
    End With
End If
If (Target.Row) = 38 And CarSale Then ActiveSheet.Range("K38") = ""


End Sub
Private Sub UpInvoice()

' Up the Invoice number by 1
If CarSale Then
    CarInvoice = GetSetting(SettingName, WorksheetName, "CarInvoiceNumber")
    CarInvoice = PadLeftString(Mid(CarInvoice, IIf(Len(CarInvoice) = 5, 2, 3)) + 1, "0", 4)
    CarInvoice = CStr(Year(Date)) - 2000 & "/" & CarInvoice
    SaveSetting SettingName, WorksheetName, "CarInvoiceNumber", CarInvoice
Else
    InvoiceNumber = GetSetting(SettingName, WorksheetName, "InvoiceNumber") + 1
    SaveSetting SettingName, WorksheetName, "InvoiceNumber", InvoiceNumber
    InvoiceNo = InvoiceNumber
End If
Me.Range(InvNoCell).Value = IIf(CarSale, CarInvoice, InvoiceNo)

End Sub

Please let me know if anymore info is needed?

Many thanks, Craig.

CraigHappy · Aug 6, 2006

Sorry, here's the regedit bit -

Hkey_Current_User – Software – VB & VBA Program Settings - Connect-2 - Develop - developit

markdmac · Aug 6, 2006

please do an export of that registry key and post the contents of the .REG file.

I hope you find this post helpful.

Regards,

Mark

Check out my scripting solutions at

http://www.thespidersparlor.com/vbscript

CraigHappy · Aug 6, 2006

Is this what you mean? =

Code:

Key Name:          HKEY_CURRENT_USER\Software\VB and VBA Program Settings\Connect-2
Class Name:        <NO CLASS>
Last Write Time:   03/08/2006 - 18:38

Key Name:          HKEY_CURRENT_USER\Software\VB and VBA Program Settings\Connect-2\Develop
Class Name:        <NO CLASS>
Last Write Time:   03/08/2006 - 18:58
Value 0
  Name:            DevelopIt
  Type:            REG_SZ
  Data:            1


Key Name:          HKEY_CURRENT_USER\Software\VB and VBA Program Settings\Connect-2\Index
Class Name:        <NO CLASS>
Last Write Time:   03/08/2006 - 18:39
Value 0
  Name:            vatrate
  Type:            REG_SZ
  Data:            17.5


Key Name:          HKEY_CURRENT_USER\Software\VB and VBA Program Settings\Connect-2\Invoice
Class Name:        <NO CLASS>
Last Write Time:   06/08/2006 - 08:54
Value 0
  Name:            CarInvoiveNumber
  Type:            REG_SZ
  Data:            4/0048

Value 1
  Name:            InvoiceNumber
  Type:            REG_SZ
  Data:            60005

Value 2
  Name:            CarInvoiceNumber
  Type:            REG_SZ
  Data:            3/0001


Key Name:          HKEY_CURRENT_USER\Software\VB and VBA Program Settings\Connect-2\Print
Class Name:        <NO CLASS>
Last Write Time:   06/08/2006 - 08:54
Value 0
  Name:            HasPrinted
  Type:            REG_SZ
  Data:            0


Key Name:          HKEY_CURRENT_USER\Software\VB and VBA Program Settings\Connect-2\SerialNo
Class Name:        <NO CLASS>
Last Write Time:   03/08/2006 - 18:42
Value 0
  Name:            SerialNumber
  Type:            REG_SZ
  Data:            90TF-7D41-78E1-89E8-596A

markdmac · Aug 6, 2006

I don't see the correlation to the registry key and print preview, however if you don't ever wish to use the "develop" mode then change this line:

DevelopIt = GetSetting(SettingName, "Develop", "DevelopIt")

To this:

DevelopIt = 0

To get rid of the headers change:

With ActiveSheet
.Shapes("WordArt 34").Visible = False ' In case it got left on
' This is the watermark bit, don't print the watermark first time
.Shapes("WordArt 34").Visible = False
.PrintOut , , 1, DevelopIt
' Turn on watermark now
.Shapes("WordArt 34").Visible = True
.PrintOut , , 1, DevelopIt
' Turn it off again
.Shapes("WordArt 34").Visible = False
End With

Change to this:

With ActiveSheet
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.Shapes("WordArt 34").Visible = False ' In case it got left on
' This is the watermark bit, don't print the watermark first time
.Shapes("WordArt 34").Visible = False
.PrintOut , , 1, DevelopIt
' Turn on watermark now
.Shapes("WordArt 34").Visible = True
.PrintOut , , 1, DevelopIt
' Turn it off again
.Shapes("WordArt 34").Visible = False
End With

I hope you find this post helpful.

Regards,

Mark

Check out my scripting solutions at

http://www.thespidersparlor.com/vbscript

CraigHappy · Aug 6, 2006

Hi Mark

Many thanks for your help.
I've changed the code as described, and the headers are gone with the regedit DevelopIt set to 0, but when I click the custom print button within the program, I now get a message window saying -

Microsoft Visual Basics
Run-time error '438':

Object doesn't support this property or method

Any suggestions?

Cheers, Craig.

markdmac · Aug 6, 2006

If setting the develop part to 0 resolved both errors then you could try doing it without the header mods.

I hope you find this post helpful.

Regards,

Mark

Check out my scripting solutions at

http://www.thespidersparlor.com/vbscript

CraigHappy · Aug 6, 2006

Hi Mark

That sorted the printing problem, fantastic!

Just one last question, if that's ok?

He says that the more the program is used, the slower it gets to opening and closing.
He was told by a 3rd party that everytime an invoice is created a temp file is made and these build up and by deleting these temp files every so often, the program works fast again.
Any idea where these files would be stored, so we can delete them?

Many thanks again, Craig.

markdmac · Aug 6, 2006

the more the program is used

What program?

Have you tried searching for *.tmp on the hard disk? Check the working directory for the program.

I hope you find this post helpful.

Regards,

Mark

Check out my scripting solutions at

http://www.thespidersparlor.com/vbscript

CraigHappy · Aug 7, 2006

Hi Mark

I mean the script, I call it a program because it's running within Excel.

I've done a search for *.tmp files and nothing stands out that could be related to the script. But we're see how things go.

Thank you very much again for you timne and help, it has been very much appreciated.

Cheers, Craig.

markdmac · Aug 8, 2006

By default a script will create any files in the same directory as the script itself.

I hope you find this post helpful.

Regards,

Mark

Check out my scripting solutions at

http://www.thespidersparlor.com/vbscript

Tek-Tips is the largest IT community on the Internet today!

Members share and learn making Tek-Tips Forums the best source of peer-reviewed technical information on the Internet!

VB script in Excel prints with a preview? 1

CraigHappy

Technical User

markdmac

MIS

CraigHappy

Technical User

CraigHappy

Technical User

markdmac

MIS

CraigHappy

Technical User

markdmac

MIS

CraigHappy

Technical User

markdmac

MIS

CraigHappy

Technical User

markdmac

MIS

CraigHappy

Technical User

markdmac

MIS

Similar threads

Part and Inventory Search

Sponsor