将Vba代码转换成Php代码,自己写的实用VBA代码合集

Sub 替换昨今去()

Dim Yesterday_Day As Integer, Yesterday As String, Yesterday_Month As Integer, Yesterday_Year As Integer

Dim Today_Day As Integer, Today_Month As Integer, Today_Year As Integer

Yesterday = DateAdd('d', -1, Date)

Yesterday_Day = Day(Yesterday)

Yesterday_Month = Month(Yesterday)

Yesterday_Year = Year(Yesterday)

Today_Day = Day(Date)

Today_Month = Month(Date)

Today_Year = Year(Date)

'选择性粘贴

Selection.PasteAndFormat (wdPasteDefault)

Selection.Find.ClearFormatting

Selection.Find.Replacement.ClearFormatting

'取消所有超链接

Dim cc As Field

For Each cc In ActiveDocument.Fields

If cc.Type = wdFieldHyperlink Then

cc.Unlink

End If

Next

Set cc = Nothing

'替换昨天、昨日

With Selection.Find

.Text = '昨[天日]{1}'

.Replacement.Text = Yesterday_Month & '月' & Yesterday_Day & '日'

.Forward = True

.Wrap = wdFindContinue

.MatchByte = False

.MatchWildcards = True

End With

Selection.Find.Execute Replace:=wdReplaceAll

'替换今天、今日

With Selection.Find

.Text = '今[天日]{1}'

.Replacement.Text = Today_Month & '月' & Today_Day & '日'

.Forward = True

.Wrap = wdFindContinue

.MatchByte = False

.MatchWildcards = True

End With

Selection.Find.Execute Replace:=wdReplaceAll

'替换今年

With Selection.Find

.Text = '今年'

.Replacement.Text = Today_Year & '年'

.Forward = True

.Wrap = wdFindContinue

.MatchByte = False

.MatchWildcards = True

End With

Selection.Find.Execute Replace:=wdReplaceAll

'替换去年

With Selection.Find

.Text = '去年'

.Replacement.Text = Today_Year - 1 & '年'

.Forward = True

.Wrap = wdFindContinue

.MatchByte = False

.MatchWildcards = True

End With

Selection.Find.Execute Replace:=wdReplaceAll

'删象屿期货的段前符号

With Selection.Find

.Text = ChrW(61548)

.Replacement.Text = ''

.Forward = True

.Wrap = wdFindContinue

.MatchByte = True

.MatchWildcards = False

End With

Selection.Find.Execute Replace:=wdReplaceAll

'手动换行符替换成回车符

With Selection.Find

.Text = '^l'

.Replacement.Text = '^p'

.Forward = True

.Wrap = wdFindContinue

.MatchByte = True

.MatchWildcards = False

End With

Selection.Find.Execute Replace:=wdReplaceAll

'段与段顶多只隔一行，将任意个回车符号替换成二个

With Selection.Find

.Text = '(^13)@'

.Replacement.Text = '^p^p'

.Forward = True

.Wrap = wdFindContinue

.MatchByte = False

.MatchWildcards = True

End With

Selection.Find.Execute Replace:=wdReplaceAll

'全选+剪切

Selection.WholeStory

Selection.Cut

End Sub

7.提取word文档里的图片

Sub 存成html()

Application.ScreenUpdating = False

Dim FileName As String

FileName = InputBox('请输入文件名')

Selection.Copy

Documents.Add DocumentType:=wdNewBlankDocument

Selection.PasteAndFormat (wdPasteDefault)

'若无目录则创建

If Dir('D:\backup\140591\桌面\报告temp\', vbDirectory) = '' Then MkDir 'D:\backup\140591\桌面\报告temp\'

ActiveDocument.SaveAs FileName:='D:\backup\140591\桌面\报告temp\' & FileName, FileFormat:=wdFormatHTML, _

LockComments:=False, Password:='', AddToRecentFiles:=True, WritePassword _

:='', ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _

SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:= _

False

ActiveWindow.View.Type = wdWebView

'段与段顶多只隔一行，将任意个回车符号替换成二个

With Selection.Find

.Text = '(^13)@'

.Replacement.Text = '^p^p'

.Forward = True

.Wrap = wdFindContinue

.MatchByte = False

.MatchWildcards = True

End With

Selection.Find.Execute Replace:=wdReplaceAll

'全选+剪切

Selection.WholeStory

Selection.Cut

ActiveDocument.Close False

Application.ScreenUpdating = True

MsgBox '已完成！'

End Sub

8.Word 删除新闻中的多余代码和文字

Sub 新闻排版()

'

'

'选择性粘贴

Selection.PasteAndFormat (wdPasteDefault)

Selection.Find.ClearFormatting

Selection.Find.Replacement.ClearFormatting

'删图片

Dim oInlineShape As InlineShape

For Each oInlineShape In ActiveDocument.InlineShapes

oInlineShape.Delete

Next

'取消所有超链接

Dim cc As Field

For Each cc In ActiveDocument.Fields

If cc.Type = wdFieldHyperlink Then

cc.Unlink

End If

Next

Set cc = Nothing

'删(微博)[微博]

With Selection.Find

.Text = '[\[\(\(]微博[\)\]\)]'

.Replacement.Text = ''

.Forward = True

.Wrap = wdFindContinue

.MatchByte = False

.MatchWildcards = True

End With

Selection.Find.Execute Replace:=wdReplaceAll

'删(博客,微博)

With Selection.Find

.Text = '(博客,微博)'

.Replacement.Text = '^p^p'

.Forward = True

.Wrap = wdFindContinue

.MatchByte = True

.MatchWildcards = False

End With

Selection.Find.Execute Replace:=wdReplaceAll

'删象屿期货的段前符号

With Selection.Find

.Text = ChrW(61548)

.Replacement.Text = ''

.Forward = True

.Wrap = wdFindContinue

.MatchByte = True

.MatchWildcards = False

End With

Selection.Find.Execute Replace:=wdReplaceAll

'删小标题后的/

With Selection.Find

.Text = '/^p'

.Replacement.Text = '^p'

.Forward = True

.Wrap = wdFindContinue

.MatchByte = True

.MatchWildcards = False

End With

Selection.Find.Execute Replace:=wdReplaceAll

'删股票代码

With Selection.Find

.Text = '\([\-0-9.]{1,}[,^s]{1,}[\-0-9.]{1,}[,^s]{1,}[\-0-9.%]{1,}\)'

.Replacement.Text = ''

.Forward = True

.Wrap = wdFindContinue

.MatchByte = False

.MatchWildcards = True

End With

Selection.Find.Execute Replace:=wdReplaceAll

'删股票涨跌值

With Selection.Find

.Text = '\[[\-0-9.%]{1,}\]'

.Replacement.Text = ''

.Forward = True

.Wrap = wdFindContinue

.MatchByte = False

.MatchWildcards = True

End With

Selection.Find.Execute Replace:=wdReplaceAll

'删[2.98% 资金 研报]

With Selection.Find

.Text = '\[[\-0-9.%]{1,}^s资金^s研报\]'

.Replacement.Text = ''

.Forward = True

.Wrap = wdFindContinue

.MatchByte = False

.MatchWildcards = True

End With

Selection.Find.Execute Replace:=wdReplaceAll

'删(600648,股吧)

With Selection.Find

.Text = '\([0-9]{6},[股吧基金]{2,3}\)'

.Replacement.Text = ''

.Forward = True

.Wrap = wdFindContinue

.MatchByte = False

.MatchWildcards = True

End With

Selection.Find.Execute Replace:=wdReplaceAll

'手动换行符替换成回车符

With Selection.Find

.Text = '^l'

.Replacement.Text = '^p'

.Forward = True

.Wrap = wdFindContinue

.MatchByte = True

.MatchWildcards = False

End With

Selection.Find.Execute Replace:=wdReplaceAll

'段与段顶多只隔一行，将任意个回车符号替换成二个

With Selection.Find

.Text = '(^13)@'

.Replacement.Text = '^p^p'

.Forward = True

.Wrap = wdFindContinue

.MatchByte = False

.MatchWildcards = True

End With

Selection.Find.Execute Replace:=wdReplaceAll

'全选+剪切

Selection.WholeStory

Selection.Cut

End Sub

9.Excel双击则复制单元格内容到剪切板

放到Worksheet对应的代码中

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

With CreateObject('new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}')

.SetText Target

.PutInClipboard

End With

End Sub

10.用对话框打开Excel文件

iFileName = Application.GetOpenFilename('Excel文件 (*.xlsx;*.xls), *.xlsx;*.xls')

11.Excel按指定列升序排列

With wbf.Sort

.SortFields.Clear

.SortFields.Add Key:=Range('B1'), SortOn:=xlSortOnValues, Order:=xlAscending 'descending，递减。Ascending，递增

.SetRange Range('A1').CurrentRegion '排序区域

.Header = xlGuess '第一行包含标题

.MatchCase = False '不区分大小写

.Orientation = xlTopToBottom

.SortMethod = xlPinYin

.Apply

End With

12.汉字编码成URL用的字符串

Public Function Escape(ByVal strText As String) As String

Set JS = CreateObject('msscriptcontrol.scriptcontrol')

JS.Language = 'JavaScript'

Escape = JS.eval_r('encodeURI('' & Replace(strText, ''', '\'') & '');')

End Function