常用代码归集

kszcs

留个记号，期待表格化

jsgj2023

Sub 从工作表发送邮件()
Dim objcdo As New ado.Message
Dim 正文 As String
Dim 收件人 As String
Dim smsg As String
If MsgBox("." & vbCr & "可以吗?", vbYesNo) = vbNo Then Exit Sub
On Error GoTo 错误处理
收件人 = Range("收件人地址") & "先生(女士)<" & WorksheetFunction.VLookup(Range("目的地"), Range("收件人一览表"), 2, False) & ">"
正文 = Replace(Range("正文"), vbLf, vbCrLf)
With objcdo
    With .Configuration.Fields
        .Item(cdoSendUsingMethod) = cdoSendUsingPort
        .Item(cdoSMTPServer) = Range("smtp").Value
        .Item(cdoSMTPServerPort) = Range("接口").Value
        .Item(cdoSMTPConnectionTimeout) = 60
        .Item(cdoSMTPAuthenticate) = "shift-jis"
        .Update
    End With
    .MimeFormatted = True
    .form = Range("发件人").Value
    .To = 收件人
    .Subject = Range("主题").Value
    .TextBody = 正文
    .TextBodyPart.Charset = "shift-jis"
    .Send
End With
Exit Sub
错误处理:
smsg = "错误: " & Err.Number & vbCrLf & Err.Description
msgboxsmsg , vbOKOnly, "发送错误"
End Sub

jsgj2023

'在工作表上显示google地图
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target <> Range("c2") Then Exit Sub
    Dim surl As String
    Dim wait_time As Date
    surl = "http://maps.google.co.jp/"
    Application.ScreenUpdating = False
    With ActiveSheet.googlemap
    .navigate surl
    Do While .busy
        DoEvents
    Loop
    Do While .readystate <> 4
        DoEvents
    Loop
    .document.all("q_d").Value = Range("c5").Value
    .document.forms(0).submit
    wait_time = DateAdd("s", 2, Now())
    Do While Now() < wait_time
        DoEvents
    Loop
    .document.all("paneltoggle2").Click
    End With
    ActiveSheet.Hyperlinks.Add
    Anchor:=range("C7"),Address:=range("C7").Value
    Application.ScreenUpdating = True
End Sub

jsgj2023

Sub 插入分页符()
Dim dyfw   As Range
Dim col  As Integer
Dim i As Long
Set dyfw = Range("datebase")
col = 2
With ActiveSheet
    .PageSetup.PrintTitleRows = dyfw.Resize(1)
    .EntireRow.Address
    .PageSetup.PrintArea = dyfw.Address
    .ResetAllPageBreaks
End With
For i = 2 To dyfw.Rows.Count - 1
    If dyfw.Cells(i, col).Value <> dyfw.Cells(i + 1, col).Value Then
        dyfw.Cells(i + 1, 1).PageBreak = xlPageBreakManual
    End If
Next i
Application.DisplayAlerts = False
    ActiveWindow.View = xlPageBreakPreview
    frmpagebreak.showvbmodeless
Application.DisplayAlerts = True
End Sub

jsgj2023

Sub 打印文件夹内的全部文件()
Dim ljm As String
Dim wjm As String
Dim gzb As Worksheet
ljm = ThisWorkbook.Path & "\打印\"
wjm = Dir(ljm & "*.xls*")
Do While wjm <> ""
    Workbooks.Open ljm & wjm
    For Each gzb In Worksheets
        If gzb.Visible = True Then
            gzb.PrintOut
        End If
    Next
    ActiveWorkbook.colse False
    wjm = Dir()
Loop
End Sub

jsgj2023

Sub 获取word的数据()
Dim sfname   As String
Dim strfilt   As String
Dim strtitle   As String
Dim docapp As word.Application
Dim pg   As word.paragraph
Dim i   As Long
Dim str1  As String
strfilt = "word文档(*.doc;*.docx;*.docm),*.doc;*.docx;*.docm,"
strtitle = "打开word文档"
sfname = Application.GetOpenFilename(filefilter:=strfilt, Title:=strtitle)
If sfname = "Fasle" Then Exit Sub
Set docapp = CreateObject("word.application")
docapp.document.Open sfname
i = 1
With docapp.activedocument
    For Each pg In .Paragraphs
        str1 = pg.Range.Text
        i = i + 1
        ActiveSheet.Cells(i, 1) = str1
    Next
End With
docapp.Quit
Set docapp = Nothing
End Sub

jsgj2023

Sub 打开word文档()
Dim sfname  As String
Dim strfilt   As String
Dim strtitle  As String
Dim docapp  As Object
strfilt = "word文档(*.doc;*.docx;*.docm),*.doc;*.docx;*.docm,"
strtitle = "打开word文档"
sfname = Application.GetOpenFilename(filefilter:=strfilt, Title:=strtitle)
If sfname = "False" Then Exit Sub
Set docapp = CreateObject("word.application")
docapp.documents.Open sfname
docapp.Visible = True
Set docapp = Nothing
End Sub

jsgj2023

Sub 显示指定文件夹的文件()
Dim spsth As String
Dim sfilename As String
Dim i As Long
sPath = Application.InputBox(prompt:="请输入文件夹的全路径名称", _
Default:=CurDir, Title:="输入文件夹", Type:=2)
If sPath = "False" Then sPath = CurDir
sPath = sPath & "\"
    With Sheet1
        .Columns(1).Clear
        .Cells(1, 1) = """ &  spath  &  ""文件夹中的文件如下:"
        .Cells(1, 1).Font.Bold = True
        sfilename = Dir(sPath, 0)
        i = 1
        Do While Len(sfilename) > 0
            .Cells(i + 1, 1) = sPath & sfilename
            sfilename = Dir()
            i = i + 1
        Loop
    End With
End Sub

苏阳湖wzy

建议楼主上传附件，谢谢！

jsgj2023

Sub 判断文件夹是否存在()
Dim sfilename As String
sfilename = Application.InputBox(prompt:="请输入文件或文件夹的名称", _
Default:=CurDir, Title:="输入名称", Type:=2)
If sfilename = "False" Then Exit Sub
If Len(Dir(sfilename, vbDirectory)) > 0 Then
    MsgBox "输入的文件或文件夹存在"
Else
    MsgBox "输入的文件或文件夹不存在!"
End If
End Sub