Kathleen0422
Board Regular
- Joined
- Apr 12, 2006
- Messages
- 188
passing it for me. I pulled this code from here last year and the project got put on hold, an well it worked then.
The user has pulled information via another macro from SQL server and now they are clicking a macro button that calls sub PrinttoPDF() File name is based on the variable AssetID. It should be passing the AssetID as the file name and suppressing the dialog box altogether. Now it is prompting me with the dialog box and the xls file name is listed as the file save as name.
'Needed to Read INI file settings
Declare Function GetPrivateProfileString Lib "kernel32" Alias _
"GetPrivateProfileStringA" (ByVal lpApplicationName As String, _
ByVal lpKeyName As Any, ByVal lpDefault As String, _
ByVal lpReturnedString As String, ByVal nSize As Long, _
ByVal lpFileName As String) As Long
'Needed to Write INI file settings
Declare Function WritePrivateProfileString Lib "kernel32" Alias _
"WritePrivateProfileStringA" (ByVal lpApplicationName As String, _
ByVal lpKeyName As Any, ByVal lpString As Any, _
ByVal lpFileName As String) As Long
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'Variables Called
Dim TheAssetID As String
Dim TheTagNumber As String
Dim TheCategory As String
Dim TheDept As String
Dim TheInservice As String
Dim TheDesc As String
Dim ThePlant As String
Dim TheSerial As String
Dim Notes As String
Sub GetAssetID()
TheAssetID = InputBox("What is the Asset Number?")
End Sub
Sub Setup_Asset()
ActiveSheet.Unprotect Password:="assets"
Application.DisplayAlerts = False
GetAssetID
If Len(TheAssetID) <> 8 Then ErrorAsset
Application.ScreenUpdating = False
Sheets("Results").Select
Range("A1").Select
With Selection.QueryTable
.Connection = _
"ODBC;DRIVER=SQL Server;SERVER=T00SQL04;UID=????;PWD=??;APP=Microsoft Office 2003;WSID=dzedandconfused"
.CommandText = Array( _
"SELECT Assets.ASSET_ID, Assets.CATEGORY, Assets.DEPT, Assets.DESCR, Assets.INSERVICE, Assets.PLANT, Assets.SERIALID, Assets.TAGNUMBER" & Chr(13) & "" & Chr(10) & "FROM AssetCatalog.dbo.Assets Assets" & Chr(13) & "" & Chr(10) & _
"WHERE (Assets.ASSET_ID='" & TheAssetID & "')" & Chr(13) & "" & Chr(10) & "ORDER BY Assets.ASSET_ID")
.Refresh BackgroundQuery:=False
End With
Notes = InputBox("Any Special Notes")
Range("B2").Select
TheCategory = ActiveCell.Value
Range("C2").Select
TheDept = ActiveCell.Value
Range("D2").Select
TheDesc = ActiveCell.Value
Range("E2").Select
TheInservice = ActiveCell.Value
Range("F2").Select
ThePlant = ActiveCell.Value
Range("G2").Select
TheSerial = ActiveCell.Value
Range("H2").Select
TheTagNumber = ActiveCell.Value
Sheets("Setup").Select
Range("C8").Select
ActiveCell.Value = TheAssetID
Range("C9").Select
ActiveCell.Value = TheTagNumber
Range("C11").Select
ActiveCell.Value = Notes
Range("B14").Select
ActiveCell.Value = TheDesc
Range("F8").Select
ActiveCell.Value = TheSerial
Range("F9").Select
ActiveCell.Value = TheCategory
Range("F10").Select
ActiveCell.Value = TheDept
Range("K8").Select
ActiveCell.Value = TheInservice
Range("K9").Select
ActiveCell.Value = ThePlant
Range("B16").Select
MsgBox ("Insert picture in Cell B16. You can use your drawing tools eg: arrows, text boxes etc. to add any additional information")
Application.Dialogs(xlDialogInsertPicture).Show
ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:= _
True, AllowInsertingColumns:=True, Password:="assets"
End Sub
Sub ErrorAsset()
MsgBox ("The asset number must be 8 characters in length"), vbExclamation
GetAssetID
End Sub
Sub SheetToPDF(WS As Worksheet, OutputFile As String)
' This subroutine will print a worksheet to a PDF file using PDF995, a free utility
' to generate PDF files. Download it at www.pdf995.com
' Two arguments must be passed into this routine
' 1. WS - A worksheet pointer
' 2. OutputFile - The full path and name of the desired pdf file
' Be sure to check that the "Generating PDF CS" setting in pdfsync.ini is set to 0
' when pdf995 is idle. This codes uses that as a completion flag as it seems to be
' the most reliable indication that PDF995 is done writing the pdf file.
Dim syncfile As String, maxwaittime As Long
Dim iniFileName As String 'tmpPrinter As Printer
Dim x As Long
Dim tmpoutputfile As String, tmpAutoLaunch As String
' set the location of the PDF995.ini and the pdfsync files
iniFileName = "c:\pdf995\res\pdf995.ini"
syncfile = "c:\pdf995\res\pdfsync.ini"
' save current settings from the PDF995.ini file
tmpoutputfile = ReadINIfile("PARAMETERS", "Output File", iniFileName)
tmpAutoLaunch = ReadINIfile("PARAMETERS", "Autolaunch", iniFileName)
' remove previous pdf if it exists
On Error Resume Next
Kill OutputFile
On Error GoTo Cleanup
' setup new values in PDF995.ini
x = WritePrivateProfileString("PARAMETERS", "Output File", OutputFile, iniFileName)
x = WritePrivateProfileString("PARAMETERS", "AutoLaunch", "0", iniFileName)
'print the worksheet
WS.Select
ActiveWindow.SelectedSheets.PrintOut Copies:=1, ActivePrinter:="PDF995"
' PDF995 operates asynchronously. We need to determine when it is done so we can
' continue. This is done by checking the "Generating PDF CS" parameter in the pdfsync.ini
' file. A loop with a 2 second delay is used to determine when it is finished.
Sleep (2000) ' pause 2 seconds (1000 = 1 sec)
maxwaittime = 60000 'If pdf995 isn't done in 60 seconds, quit anyway
Do While ReadINIfile("PARAMETERS", "Generating PDF CS", syncfile) = "1" And maxwaittime > 0
Sleep (600) ' pause 2 seconds and re-check the status
maxwaittime = maxwaittime - 600
Loop
' restore the original default printer and the PDF995.ini settings
Cleanup:
x = WritePrivateProfileString("PARAMETERS", "Output File", tmpoutputfile, iniFileName)
x = WritePrivateProfileString("PARAMETERS", "AutoLaunch", tmpAutoLaunch, iniFileName)
x = WritePrivateProfileString("PARAMETERS", "Launch", "", iniFileName)
On Error Resume Next
End Sub
Function ReadINIfile(sSection As String, sEntry As String, sFilename As String) As String
Dim x As Long
Dim sDefault As String
Dim sRetBuf As String, iLenBuf As Integer
Dim sValue As String
'Six arguments
'Explanation of arguments:
'sSection: ini file section (always between brackets)
'sEntry : word on left side of "=" sign
'sDefault$: value returned if function is unsuccessful
'sRetBuf$ : the value you're looking for will be copied to this buffer string
'iLenBuf% : Length in characters of the buffer string
'sFileName: Path to the ini file
sDefault$ = ""
sRetBuf$ = String$(256, 0) '256 null characters
iLenBuf% = Len(sRetBuf$)
x = GetPrivateProfileString(sSection, sEntry, _
sDefault$, sRetBuf$, iLenBuf%, sFilename)
ReadINIfile = Left$(sRetBuf$, x)
End Function
Sub PrintToPDF()
Stop
' This example prints the first sheet of the workbook. It calls the SheetToPDF subroutine,
' passing it the worksheet pointer, and the PDFFileName (the AssetID name + .pdf)
Dim PDFFileName As String
PDFFileName = "c:\AssetCatalog\PDFs\" & TheAssetID & ".pdf"
Call SheetToPDF(Sheets(1), PDFFileName)
Sheets("Database").Select
Range("A65000").Select
Selection.End(xlUp).Select
ActiveCell.Offset(1, 0).Select
'Record TagNumber
Selection.NumberFormat = "General"
ActiveCell.FormulaR1C1 = "=Setup!R9C3"
'Record AssetID
ActiveCell.Offset(0, 1).Select
Selection.NumberFormat = "General"
ActiveCell.FormulaR1C1 = "=Setup!R8C3"
'Record Date PDF was created
ActiveCell.Offset(0, 1).Select
Selection.NumberFormat = "[$-409]dd-mmm-yy;@"
ActiveCell.FormulaR1C1 = "=TODAY()"
Rows.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveSheet.Paste
Application.CutCopyMode = False
'Clean up Old Values
Sheets("Setup").Select
ActiveSheet.Unprotect Password:="assets"
Range("C8:C9").Select
Selection.ClearContents
Range("C11").Select
Selection.ClearContents
Range("B14").Select
Selection.ClearContents
Range("F8:F10").Select
Selection.ClearContents
Range("K8:K9").Select
Selection.ClearContents
ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:=True
MsgBox ("Please delete image before proceeding")
End Sub
Thanks for any help.
The user has pulled information via another macro from SQL server and now they are clicking a macro button that calls sub PrinttoPDF() File name is based on the variable AssetID. It should be passing the AssetID as the file name and suppressing the dialog box altogether. Now it is prompting me with the dialog box and the xls file name is listed as the file save as name.
'Needed to Read INI file settings
Declare Function GetPrivateProfileString Lib "kernel32" Alias _
"GetPrivateProfileStringA" (ByVal lpApplicationName As String, _
ByVal lpKeyName As Any, ByVal lpDefault As String, _
ByVal lpReturnedString As String, ByVal nSize As Long, _
ByVal lpFileName As String) As Long
'Needed to Write INI file settings
Declare Function WritePrivateProfileString Lib "kernel32" Alias _
"WritePrivateProfileStringA" (ByVal lpApplicationName As String, _
ByVal lpKeyName As Any, ByVal lpString As Any, _
ByVal lpFileName As String) As Long
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'Variables Called
Dim TheAssetID As String
Dim TheTagNumber As String
Dim TheCategory As String
Dim TheDept As String
Dim TheInservice As String
Dim TheDesc As String
Dim ThePlant As String
Dim TheSerial As String
Dim Notes As String
Sub GetAssetID()
TheAssetID = InputBox("What is the Asset Number?")
End Sub
Sub Setup_Asset()
ActiveSheet.Unprotect Password:="assets"
Application.DisplayAlerts = False
GetAssetID
If Len(TheAssetID) <> 8 Then ErrorAsset
Application.ScreenUpdating = False
Sheets("Results").Select
Range("A1").Select
With Selection.QueryTable
.Connection = _
"ODBC;DRIVER=SQL Server;SERVER=T00SQL04;UID=????;PWD=??;APP=Microsoft Office 2003;WSID=dzedandconfused"
.CommandText = Array( _
"SELECT Assets.ASSET_ID, Assets.CATEGORY, Assets.DEPT, Assets.DESCR, Assets.INSERVICE, Assets.PLANT, Assets.SERIALID, Assets.TAGNUMBER" & Chr(13) & "" & Chr(10) & "FROM AssetCatalog.dbo.Assets Assets" & Chr(13) & "" & Chr(10) & _
"WHERE (Assets.ASSET_ID='" & TheAssetID & "')" & Chr(13) & "" & Chr(10) & "ORDER BY Assets.ASSET_ID")
.Refresh BackgroundQuery:=False
End With
Notes = InputBox("Any Special Notes")
Range("B2").Select
TheCategory = ActiveCell.Value
Range("C2").Select
TheDept = ActiveCell.Value
Range("D2").Select
TheDesc = ActiveCell.Value
Range("E2").Select
TheInservice = ActiveCell.Value
Range("F2").Select
ThePlant = ActiveCell.Value
Range("G2").Select
TheSerial = ActiveCell.Value
Range("H2").Select
TheTagNumber = ActiveCell.Value
Sheets("Setup").Select
Range("C8").Select
ActiveCell.Value = TheAssetID
Range("C9").Select
ActiveCell.Value = TheTagNumber
Range("C11").Select
ActiveCell.Value = Notes
Range("B14").Select
ActiveCell.Value = TheDesc
Range("F8").Select
ActiveCell.Value = TheSerial
Range("F9").Select
ActiveCell.Value = TheCategory
Range("F10").Select
ActiveCell.Value = TheDept
Range("K8").Select
ActiveCell.Value = TheInservice
Range("K9").Select
ActiveCell.Value = ThePlant
Range("B16").Select
MsgBox ("Insert picture in Cell B16. You can use your drawing tools eg: arrows, text boxes etc. to add any additional information")
Application.Dialogs(xlDialogInsertPicture).Show
ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:= _
True, AllowInsertingColumns:=True, Password:="assets"
End Sub
Sub ErrorAsset()
MsgBox ("The asset number must be 8 characters in length"), vbExclamation
GetAssetID
End Sub
Sub SheetToPDF(WS As Worksheet, OutputFile As String)
' This subroutine will print a worksheet to a PDF file using PDF995, a free utility
' to generate PDF files. Download it at www.pdf995.com
' Two arguments must be passed into this routine
' 1. WS - A worksheet pointer
' 2. OutputFile - The full path and name of the desired pdf file
' Be sure to check that the "Generating PDF CS" setting in pdfsync.ini is set to 0
' when pdf995 is idle. This codes uses that as a completion flag as it seems to be
' the most reliable indication that PDF995 is done writing the pdf file.
Dim syncfile As String, maxwaittime As Long
Dim iniFileName As String 'tmpPrinter As Printer
Dim x As Long
Dim tmpoutputfile As String, tmpAutoLaunch As String
' set the location of the PDF995.ini and the pdfsync files
iniFileName = "c:\pdf995\res\pdf995.ini"
syncfile = "c:\pdf995\res\pdfsync.ini"
' save current settings from the PDF995.ini file
tmpoutputfile = ReadINIfile("PARAMETERS", "Output File", iniFileName)
tmpAutoLaunch = ReadINIfile("PARAMETERS", "Autolaunch", iniFileName)
' remove previous pdf if it exists
On Error Resume Next
Kill OutputFile
On Error GoTo Cleanup
' setup new values in PDF995.ini
x = WritePrivateProfileString("PARAMETERS", "Output File", OutputFile, iniFileName)
x = WritePrivateProfileString("PARAMETERS", "AutoLaunch", "0", iniFileName)
'print the worksheet
WS.Select
ActiveWindow.SelectedSheets.PrintOut Copies:=1, ActivePrinter:="PDF995"
' PDF995 operates asynchronously. We need to determine when it is done so we can
' continue. This is done by checking the "Generating PDF CS" parameter in the pdfsync.ini
' file. A loop with a 2 second delay is used to determine when it is finished.
Sleep (2000) ' pause 2 seconds (1000 = 1 sec)
maxwaittime = 60000 'If pdf995 isn't done in 60 seconds, quit anyway
Do While ReadINIfile("PARAMETERS", "Generating PDF CS", syncfile) = "1" And maxwaittime > 0
Sleep (600) ' pause 2 seconds and re-check the status
maxwaittime = maxwaittime - 600
Loop
' restore the original default printer and the PDF995.ini settings
Cleanup:
x = WritePrivateProfileString("PARAMETERS", "Output File", tmpoutputfile, iniFileName)
x = WritePrivateProfileString("PARAMETERS", "AutoLaunch", tmpAutoLaunch, iniFileName)
x = WritePrivateProfileString("PARAMETERS", "Launch", "", iniFileName)
On Error Resume Next
End Sub
Function ReadINIfile(sSection As String, sEntry As String, sFilename As String) As String
Dim x As Long
Dim sDefault As String
Dim sRetBuf As String, iLenBuf As Integer
Dim sValue As String
'Six arguments
'Explanation of arguments:
'sSection: ini file section (always between brackets)
'sEntry : word on left side of "=" sign
'sDefault$: value returned if function is unsuccessful
'sRetBuf$ : the value you're looking for will be copied to this buffer string
'iLenBuf% : Length in characters of the buffer string
'sFileName: Path to the ini file
sDefault$ = ""
sRetBuf$ = String$(256, 0) '256 null characters
iLenBuf% = Len(sRetBuf$)
x = GetPrivateProfileString(sSection, sEntry, _
sDefault$, sRetBuf$, iLenBuf%, sFilename)
ReadINIfile = Left$(sRetBuf$, x)
End Function
Sub PrintToPDF()
Stop
' This example prints the first sheet of the workbook. It calls the SheetToPDF subroutine,
' passing it the worksheet pointer, and the PDFFileName (the AssetID name + .pdf)
Dim PDFFileName As String
PDFFileName = "c:\AssetCatalog\PDFs\" & TheAssetID & ".pdf"
Call SheetToPDF(Sheets(1), PDFFileName)
Sheets("Database").Select
Range("A65000").Select
Selection.End(xlUp).Select
ActiveCell.Offset(1, 0).Select
'Record TagNumber
Selection.NumberFormat = "General"
ActiveCell.FormulaR1C1 = "=Setup!R9C3"
'Record AssetID
ActiveCell.Offset(0, 1).Select
Selection.NumberFormat = "General"
ActiveCell.FormulaR1C1 = "=Setup!R8C3"
'Record Date PDF was created
ActiveCell.Offset(0, 1).Select
Selection.NumberFormat = "[$-409]dd-mmm-yy;@"
ActiveCell.FormulaR1C1 = "=TODAY()"
Rows.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveSheet.Paste
Application.CutCopyMode = False
'Clean up Old Values
Sheets("Setup").Select
ActiveSheet.Unprotect Password:="assets"
Range("C8:C9").Select
Selection.ClearContents
Range("C11").Select
Selection.ClearContents
Range("B14").Select
Selection.ClearContents
Range("F8:F10").Select
Selection.ClearContents
Range("K8:K9").Select
Selection.ClearContents
ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:=True
MsgBox ("Please delete image before proceeding")
End Sub
Thanks for any help.