VBA 调用打印机实战开发

本文主要是介绍VBA 调用打印机实战开发，希望对大家解决编程问题提供一定的参考价值，需要的开发者们随着小编来一起学习吧！

VBA 调用打印机实战开发

Public Type POINTAPI
X As Long
Y As Long
End Type#If Win64 ThenPublic Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As LongPublic Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As Rect) As Long
#ElsePublic Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As LongPublic Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As Rect) As Long
#End IfPublic Type RectLeft As Longtop As LongRight As LongBottom As Long
End TypePublic rtnDate
Public isLimited As BooleanType IResultisFind As BooleanresultVal As String
End TypeFunction GetSysCompany()'GetSysCompany = "广州聚才装修有限公司"GetSysCompany = "广州聚才装修有限公司"End Function
Sub clearRows(strWs As String, str_rptRng As String, strRngJoin As String)
Dim ws As Worksheet
Set ws = Worksheets(strWs)
Dim strPara() As String
'"A6:N?"
strPara = Split(str_rptRng, ":")'ws.Range(strPara(0) & ":" & Replace(strPara(1), "?", ws.Rows.Count)).ClearContentsws.Range(Range(strPara(0)).Row & ":" & ws.Rows.Count).DeleteIf strRngJoin <> "" Thenws.Range(strRngJoin).Value = ""
End IfEnd Sub
Sub selectAllShape()Dim sh As ShapeDim sb As New StringBuliderFor Each sh In Selection.Worksheet.ShapesIf Intersect(Selection, sh.TopLeftCell) Is Nothing = False Thensb.AppendFh sh.Name, vbNewLineEnd IfNext shSelection.Worksheet.Shapes.Range(Split(sb.ToString(), vbNewLine)).Select
End Sub
Sub ChkSetFocus(rng As Range, rngs As Range, Optional rngSelect As String = "A1")If Intersect(rng, rngs) Is Nothing = False Thenrng.Worksheet.Range(rngSelect).Select
End IfEnd Sub
Sub GotoTop(intRow As Integer)ActiveWindow.ScrollRow = intRowEnd SubFunction ItextJoin(rngs As Range, Optional fh As String = ",")Dim sb As New StringBuliderDim rng As RangeFor Each rng In rngssb.AppendFh rng.Value, fhNext rngItextJoin = sb.ToStringEnd Function'--检测账号密码是否正确---
Function CheckUser(userName As String, Pw As String) As BooleanDim wsUser As WorksheetDim rowNo As LongDim strPw As StringOn Error GoTo er:Set wsUser = ThisWorkbook.Worksheets("用户信息")rowNo = Application.WorksheetFunction.Match(userName, wsUser.Range("A:A"), 0)If rowNo > 0 ThenstrPw = wsUser.Range("B" & rowNo)If Pw = strPw ThenCheckUser = TrueElseMsgBox "密码错误"CheckUser = FalseEnd IfElseMsgBox "账户不存在"CheckUser = FalseEnd IfExit Functioner:Dim intLen  As IntegerintLen = InStr(err.Description, "不能取得")If intLen > 0 ThenMsgBox "账户不存在"ElseMsgBox err.DescriptionEnd IfEnd FunctionFunction CheckLimited() As BooleanDim chk As Booleanchk = TrueIf isLimited = True ThenDim strErrMsg As StringDim beginDate As StringDim endDate As StringDim intday As IntegerDim intCount As IntegerstrErrMsg = "ErrCode:3168"beginDate = "2021-07-05"endDate = Format(Now(), "yyyy-MM-dd")intday = 10intCount = 20If (DateDiff("d", beginDate, endDate) >= intday) ThenMsgBox strErrMsg, vbExclamation, "Error"chk = FalseEnd IfIf (intLoadCount > intCount) ThenMsgBox strErrMsg, vbExclamation, "Error"chk = FalseEnd IfEnd IfCheckLimited = chkEnd Function
Function getws(strwsName As String) As WorksheetDim ws As WorksheetSet ws = ThisWorkbook.Worksheets(strwsName)Set getws = ws
End Function
Sub displayWsTabs()Dim thisWin As WindowSet thisWin = ThisWorkbook.Windows(ThisWorkbook.Name)thisWin.DisplayWorkbookTabs = Not thisWin.DisplayWorkbookTabs
End Sub'--打印预览--支持隐藏区域--------
Sub cmd_print()Dim rngNoPrint As RangeDim isPrint As BooleanDim NoPrintRng As StringDim rng As RangeDim sb As New StringBuliderDim arrContent As VariantDim rowLine As VariantDim keyVal As VariantIf (ActiveSheet.CodeName = "sh_rk") ThenNoPrintRng = GetSetVal("rkBill_NOPrintRng")End IfIf (ActiveSheet.CodeName = "sh_ck") ThenNoPrintRng = GetSetVal("ckBill_NOPrintRng")End IfisPrint = IIf(Trim(NoPrintRng) = "", True, False)If isPrint = False ThenFor Each rng In Range(NoPrintRng)sb.AppendFh rng.Address & "|" & rng.Value, "~"rng.Value = ""Next rngEnd IfActiveSheet.PrintPreviewIf isPrint = False ThenarrContent = Split(sb.ToString(), "~")For Each rowLine In arrContentkeyVal = Split(rowLine, "|")Range(keyVal(0)).Value = keyVal(1)Next rowLineEnd IfEnd Sub
Sub cmd_exportPDFRng(rng As Range, strFileName As String)On Error GoTo err:Dim pdfFileName As StringDim pdfName As StringpdfName = strFileNameIf Trim(pdfName) = "" ThenpdfName = "PDF_" & wsBill.Name & Format(Now, "_yyMMddHHmm")End IfpdfFileName = Application.GetSaveAsFilename(pdfName, "PDF Files(*.pdf), *.pdf", , "导出PDF文件")If pdfFileName <> "False" Thenrng.ExportAsFixedFormat xlTypePDF, pdfFileName, xlQualityStandard, , , , , TrueEnd IfExit Sub
err:MsgBox err.Description
End Sub'--系统初始化-------
Sub sysStart()On Error GoTo err:Dim wsBillRec As WorksheetIf MsgBox("确定要初始化系统吗?" & vbCrLf & vbCrLf & "初始化后,报价单数据会清空!", vbQuestion + vbYesNo + vbDefaultButton2, "确认提示") = vbNo ThenExit SubEnd IfIf MsgBox("确定真的要初始化系统吗?" & vbCrLf & vbCrLf & "初始化后,数据会清空，无法恢复!!!", vbCritical + vbYesNo + vbDefaultButton2, "确认提示") = vbNo ThenExit SubEnd If' Set wsBillRec = Worksheets(GetSetVal("rkBill_saveRecWsName"))
' wsBillRec.Range("2:" & ActiveSheet.Rows.Count).DeleteSet wsBillRec = Worksheets(GetSetVal("ckBill_saveRecWsName"))wsBillRec.Range("2:" & ActiveSheet.Rows.Count).DeleteSet wsBillRec = Worksheets("系统单号")wsBillRec.Range("2:" & ActiveSheet.Rows.Count).DeleteThisWorkbook.SaveMsgBox "初始化成功!", vbInformation, "提示"Exit Suberr:MsgBox err.Description
End Sub
Function uIsNull(objVal, Optional defaultVal As String = "")uIsNull = IIf(IsNull(objVal), defaultVal, objVal)End FunctionFunction FindError(ws As Worksheet, sRng) As BooleanDim rng As RangeOn Error GoTo lineSet rng = ws.Range(sRng).SpecialCells(xlCellTypeFormulas, 16)FindError = TrueExit Function
line:FindError = False
End Function'--获取指定表的最大行号
Function GetRowCount(shName As String)GetRowCount = Worksheets(shName).Cells.SpecialCells(xlLastCell).RowEnd Function'--获取指定表的最大行号
Function GetCounta(shName As String, colName As String)GetCounta = Application.Evaluate("counta(" & shName & "!" & colName & ")")End Function'--函数功能:金额转大写----
'--num: 金额数值，intdw:单位（1:元，2:圆），xsd:小数位（最大为2位）
Function NumberStr(num As Variant, _Optional intdw As Integer = 1, _Optional xsd As Integer = 2)Dim strValue1 As StringDim strValue2 As StringDim strJf As StringDim findXsd As IntegerDim dw, jfDim strDw As StringOn Error GoTo er:If (CDbl(num) = 0) ThenNumberStr = "零元"End Ifjf = [{"角","分"}]dw = [{"元","圆"}]If intdw < 1 Then intdw = 1If intdw > 2 Then intdw = 2If xsd < 1 Then xsd = 1If xsd > 3 Then xsd = 3strDw = dw(intdw)findXsd = InStr(num, ".")If findXsd > 0 ThenstrValue1 = Left(num, findXsd - 1)strValue1 = Application.Evaluate("NUMBERSTRING(" & strValue1 & ",2)") & strDwstrValue2 = "0." & Mid(num, findXsd + 1)strValue2 = Application.Evaluate("ROUND(" & strValue2 & "," & xsd & ")")strValue2 = Mid(strValue2, 3)If Left(strValue2, 1) = 0 ThenstrJf = "零"ElsestrJf = Application.Evaluate("NUMBERSTRING(" & Mid(strValue2, 1, 1) & ",2)") _& jf(1)End IfIf Len(strValue2) = 2 ThenstrJf = strJf & Application.Evaluate("NUMBERSTRING(" & Mid(strValue2, 2, 1) _& ",2)") & jf(2)End IfElsestrValue1 = Application.Evaluate("NUMBERSTRING(" & num & ",2)") & strDw & "整"End IfNumberStr = strValue1 & strJfExit Function
er:NumberStr = "零元"
End Function'--小写数值转大写-------
'=IF(B4="","",IF(B4>=1000000,"","?   ") & NumberToStr(C4))
Function NumberToStr(num As Double, Optional intFh As Integer = 3)Dim str_Value As StringDim i As IntegerDim strJoin As StringDim dxdx = [{"壹","贰","叁","肆","伍","陆","柒","捌","玖"}]str_Value = Format(num, "#.00")str_Value = Replace(str_Value, ".", "")For i = 1 To Len(str_Value)If Mid(str_Value, i, 1) = "0" ThenstrJoin = strJoin & "零" & String(intFh, " ")ElsestrJoin = strJoin & dx(Mid(str_Value, i, 1)) & String(intFh, " ")End IfNext iNumberToStr = strJoinEnd FunctionFunction NumberToCNStr(num As Integer)NumberToCNStr = Application.Evaluate("NUMBERSTRING(" & num & ",1)")
End Function
Rem 获取供应商信息--------------
Function GetSupplier(supplierName As String, Optional int_col As Integer = 1)On Error GoTo er:Dim rowNo As LongDim ws As WorksheetDim strIndexCol As StringstrIndexCol = "A:A"Set ws = Worksheets("供应商信息")rowNo = Application.WorksheetFunction.Match(supplierName, ws.Range(strIndexCol), 0)GetSupplier = ws.Cells(rowNo, int_col)Exit Function
er:GetSupplier = ""
End FunctionRem 获取客户信息--------------
Function GetCustomer(customerName As String, int_col As Integer)On Error GoTo er:Dim rowNo As LongDim ws As WorksheetDim strCustomerIndexCol As StringstrCustomerIndexCol = "B:B"Set ws = Worksheets(strCustomerWsName)rowNo = Application.WorksheetFunction.Match(customerName, ws.Range(strCustomerIndexCol), 0)GetCustomer = ws.Cells(rowNo, int_col)Exit Function
er:GetCustomer = ""
End FunctionFunction openFolder(str_title As String, Optional strFileName As String = "")With Application.FileDialog(msoFileDialogSaveAs).Title = str_title.InitialFileName = ThisWorkbook.Path & "\" & strFileName.ShowIf .SelectedItems.Count = 0 ThenopenFolder = ""ElseopenFolder = .SelectedItems(1)End IfEnd With
End FunctionFunction GetBillNo(strType As String, Optional strDate As String = "", Optional isAdd As Boolean = True)Dim rngFind As RangeDim strSN As StringDim intId As IntegerDim strFindNo As StringstrFindNo = strType & Format(IIf(Trim(strDate) = "", Now(), strDate), "yyyyMMdd")strSN = "000"Dim wsBillNo As WorksheetSet wsBillNo = Worksheets("系统单号")Set rngFind = wsBillNo.Range("A:A").Find(strFindNo, LookAt:=xlWhole)If (rngFind Is Nothing = True) ThenIf (isAdd = True) ThenApplication.CutCopyMode = FalsewsBillNo.Range("A2:B2").Insert xlDownwsBillNo.Range("A2").Value = strFindNowsBillNo.Range("B2").Value = 1End IfintId = 1ElseintId = Int(wsBillNo.Range("B" & rngFind.Row).Value) + 1If (isAdd = True) ThenwsBillNo.Range("B" & rngFind.Row).Value = intIdEnd IfEnd IfGetBillNo = strFindNo & "-" & Format(intId, strSN)
End Function'-导出Excel单据----------
Sub cmd_export(strDelFormulaRng As String, ByRef exportName As String)On Error GoTo err:Dim RngAll() As StringDim wsBill As WorksheetDim wsNewbill As WorksheetDim sh As ShapeSet wsBill = ActiveSheetwsBill.Copy , wsBillSet wsNewbill = ActiveSheetIf (Trim(strDelFormulaRng) <> "") ThenRngAll = Split(strDelFormulaRng, ",")For Each strRng In RngAllwsNewbill.Range(strRng).CopywsNewbill.Range(strRng).PasteSpecial xlPasteValuesNext strRngApplication.CutCopyMode = FalseEnd IfwsNewbill.Name = "export_" & Format(Now(), "yyyyMMddhhmmss")For Each sh In wsNewbill.ShapesIf Left(sh.Name, 4) = "btn_" Then sh.DeleteNext shwsBill.SelectexportName = wsNewbill.NameExit Suberr:MsgBox err.Description
End SubSub cmd_exportPDF()On Error GoTo err:Dim pdfFileName As StringDim wsBill As WorksheetSet wsBill = ActiveSheetpdfFileName = Application.GetSaveAsFilename("PDF_" & wsBill.Name & Format(Now, "_yyMMddHHmm"), "PDF Files(*.pdf), *.pdf", , "导出PDF文件")If pdfFileName <> "False" ThenwsBill.ExportAsFixedFormat xlTypePDF, pdfFileName, xlQualityStandard, , , , , TrueEnd IfExit Sub
err:MsgBox err.Description
End SubFunction GetColName(colNumOrName As String)If Trim(CStr(Val(colNumOrName))) = colNumOrName ThenGetColName = colToChr(CInt(colNumOrName))ElseGetColName = colNumOrNameEnd IfEnd Function
Function colToNum(colName As String) As IntegercolToNum = Range(colName & ":" & colName).Column
End FunctionFunction colToChr(colNum As Integer) As StringIf colNum Mod 26 = 0 ThencolToChr = IIf(colNum \ 26 = 1, "", Chr(colNum \ 26 + 63)) & "Z"ElsecolToChr = IIf(colNum \ 26 = 0, "", Chr(colNum \ 26 + 64)) & Chr(colNum Mod 26 + 64)End If
End FunctionFunction GetPicPath()GetPicPath = ThisWorkbook.Path & "\Pic\"End Function
Function GetPicName(rngPic As Range, Optional isAddHz As Boolean = False, Optional isAddRngAddress As Boolean = False, Optional intNum As Integer = 1)Dim picName As StringpicName = "opic_" & rngPic(1).Value & "_" & Format(intNum, "00")picName = picName & IIf(isAddRngAddress = False, "", "_" & Replace(rngPic(1).Address, "$", ""))picName = picName & IIf(isAddHz = False, "", ".JPG")GetPicName = picNameEnd FunctionFunction GetPicFileName(rng As Range, Optional isChkDir As Boolean = True)Dim strFileName As StringDim rngPic As RangeIf (rng Is Nothing) ThenGetPicFileName = ""ElseSet rngPic = rng(1)strFileName = GetPicPath() & GetPicName(rng, True)If Dir(strFileName) <> "" And Trim(strFileName) <> "" ThenGetPicFileName = strFileNameElseGetPicFileName = IIf(isChkDir = True, "", strFileName)End IfEnd IfEnd Function
Function WsFindShape(picName As String, ws As Worksheet)Dim sh As ShapeDim isFind As BooleanFor Each sh In ws.ShapesIf InStr(sh.Name, picName) > 0 ThenisFind = TrueExit ForEnd IfNext shWsFindShape = isFindEnd Function
Sub cmd_reload_pic(rngs As Range, pyCol As Integer)Dim intMin As DoubleDim rg As RangeDim rng As RangeDim pic As ObjectDim picName As String'opic_D0001_01_O16For Each rg In rngspicName = "opic_" & rg.Value & "_01_" & Replace(rg.Address, "$", "")If WsFindShape(picName, rngs.Worksheet) = True ThenSet rng = rg.Offset(0, pyCol)Set pic = rngs.Worksheet.Pictures(picName)intMin = Application.WorksheetFunction.Min(rng.MergeArea.Height, rng.MergeArea.Width) - 3With pic'.Placement = xlMoveAndSize '这个属性很关键If .ShapeRange.Rotation = 0 ThenIf .Height >= .Width Then.Height = intMinElse.Width = intMinEnd IfEnd If.top = rng.top + (rng.MergeArea.Height - .Height) / 2.Left = rng.Left + (rng.MergeArea.Width - .Width) / 2End WithEnd IfNext rgEnd SubSub cmd_reload_shp(rngs As Range, pyCol As Integer)Dim intMin As DoubleDim rg As RangeDim rng As RangeDim pic As PictureDim shp As ShapeDim picName As StringDim bl As Double'opic_D0001_01_O16For Each rg In rngspicName = "opic_" & rg.Value & "_01_" & Replace(rg.Address, "$", "")If WsFindShape(picName, rngs.Worksheet) = True ThenSet rng = rg.Offset(0, pyCol)Set pic = rngs.Worksheet.Pictures.Insert(GetPicFileName(rg))Set shp = rngs.Worksheet.Shapes(picName)intMin = Application.WorksheetFunction.Min(rng.MergeArea.Height, rng.MergeArea.Width) - 3With shp.Width = pic.Width.Height = pic.Height'.Placement = xlMoveAndSize '这个属性很关键If .Rotation = 0 ThenIf .Height >= .Width Then.Height = intMinbl = pic.Height / intMin.Width = pic.Width / blElse.Width = intMinbl = pic.Width / intMin.Height = pic.Height / blEnd IfEnd If.top = rng.top + (rng.MergeArea.Height - .Height) / 2.Left = rng.Left + (rng.MergeArea.Width - .Width) / 2End Withpic.DeleteEnd IfNext rgEnd SubSub AutoSave(wsName As String, SaveDataBindCol As String, Optional InsertRow As Integer = 2)On Error GoTo err:Dim rngFind As RangeDim ws As WorksheetDim chkColArrDim SaveBataColArrDim DataRowArrDim colKeyValDim isFind As BooleanDim sbInsertRow As New StringBuliderDim qtyT As IntegerDim chkT As Integer'SaveDataBindCol(多行用vbnewLine分开)'A:A001:T|B:货品名称:T|C:规格描述:FSet ws = Worksheets(wsName)DataRowArr = Split(SaveDataBindCol, vbNewLine)For r = 0 To UBound(DataRowArr)chkColArr = Split(DataRowArr(r), "|")qtyT = 0chkT = 0For c = 0 To UBound(chkColArr)colKeyVal = Split(chkColArr(c), ":")If colKeyVal(2) = "T" Then '//检测列qtyT = qtyT + 1Set rngFind = ws.Range(colKeyVal(0) & ":" & colKeyVal(0)).Find(colKeyVal(1), LookAt:=xlWhole)If (rngFind Is Nothing = False) ThenchkT = chkT + 1 '//存在值End IfEnd IfNext cIf qtyT <> chkT Thenws.Range(InsertRow & ":" & InsertRow).Copyws.Range(InsertRow & ":" & InsertRow).Insertws.Range(InsertRow & ":" & InsertRow).Value = ""For c = 0 To UBound(chkColArr)colKeyVal = Split(chkColArr(c), ":")ws.Range(colKeyVal(0) & InsertRow).Value = colKeyVal(1)Next cEnd IfNext rApplication.CutCopyMode = FalseExit Suberr:MsgBox err.Description
End Sub

这篇关于VBA 调用打印机实战开发的文章就介绍到这儿，希望我们推荐的文章对编程师们有所帮助！

---