注册 登录
编程论坛 VFP论坛

请教:如何将visio 的vba代码 改写为vfp代码,謝謝!

ken3238 发布于 2021-12-11 11:20, 1694 次点击
请教:如何将visio 的vba代码 改写为vfp代码
工作中常要将visio流程图作繁简中文转换,但visio没有转换键,故求助于vfp方式,请各位大神帮忙,万分感谢!

只有本站会员才能查看附件,请 登录
/需繁简转换的visio流程图.

环境:win10 / vfp9.0/visio 2016

*下面是visio 的vba代码
 Option Explicit
 Private Declare PtrSafe Function LCMapString Lib "kernel32" Alias "LCMapStringA" (ByVal Locale As Long, ByVal dwMapFlags As Long, ByVal lpSrcStr As String, ByVal cchSrc As Long, ByVal lpDestStr As String, ByVal cchDest As Long) As Long

Private Function StoT(sIn As String) As String
Dim lStrLen As Long
lStrLen = LenB(sIn)
StoT = Space(lStrLen)
LCMapString &H804, &H4000000, sIn, lStrLen, StoT, lStrLen
End Function
Private Function TtoS(sIn As String) As String
Dim lStrLen As Long
lStrLen = LenB(sIn)
TtoS = Space(lStrLen)
LCMapString &H804, &H2000000, sIn, lStrLen, TtoS, lStrLen
End Function

 
Sub GBToBig5()
' 键盘快捷方式: Ctrl+w
'
'For Each cell In Selection
    'Enable diagram services
    Dim DiagramServices As Integer
    DiagramServices = ActiveDocument.DiagramServicesEnabled
    ActiveDocument.DiagramServicesEnabled = visServiceVersion140 + visServiceVersion150
    Dim R As Integer
    Dim cell As Object
    For Each cell In Application.ActiveWindow.Page.Shapes
    'If Not Application.ActiveWindow.Page.Shapes.ItemFromID(R) Is Nothing Then
    'If Application.ActiveWindow.Page.Shapes.ItemFromID(R).Text <> "" Then
   ' Application.ActiveWindow.Page.Shapes.ItemFromID(R).Text = StoT(Application.ActiveWindow.Page.Shapes.ItemFromID(R).Text)
   cell.Text = StoT(cell.Text)
    'End If
    'End If
    Next
    'Restore diagram services
    ActiveDocument.DiagramServicesEnabled = DiagramServices

End Sub

Sub Big5ToGB()
' 键盘快捷方式: Ctrl+w
'
'For Each cell In Selection
    'Enable diagram services
    Dim DiagramServices As Integer
    DiagramServices = ActiveDocument.DiagramServicesEnabled
    ActiveDocument.DiagramServicesEnabled = visServiceVersion140 + visServiceVersion150
    Dim R As Integer
    Dim cell As Object
    For Each cell In Application.ActiveWindow.Page.Shapes
    'If Not Application.ActiveWindow.Page.Shapes.ItemFromID(R) Is Nothing Then
    'If Application.ActiveWindow.Page.Shapes.ItemFromID(R).Text <> "" Then
   ' Application.ActiveWindow.Page.Shapes.ItemFromID(R).Text = StoT(Application.ActiveWindow.Page.Shapes.ItemFromID(R).Text)
   cell.Text = TtoS(cell.Text)
    'End If
    'End If
    Next
    'Restore diagram services
    ActiveDocument.DiagramServicesEnabled = DiagramServices

End Sub

 
9 回复
#2
sam_jiang2021-12-11 15:30
你代码都有了,做个宏不就完了。
#3
吹水佬2021-12-11 15:42
API LCMapString() 你之前的贴有
其他应该不用改多少
#4
ken32382021-12-11 16:16
回复 2楼 sam_jiang
是的,宏不方便,用vfp prg會便利一些.
#5
ken32382021-12-11 16:20
回复 3楼 吹水佬
我有將版主之前回复的API做法放到PRG用,但對visio的流程圖不起作用
#6
吹水佬2021-12-11 21:57
以下是引用ken3238在2021-12-11 16:20:21的发言:

我有將版主之前回复的API做法放到PRG用,但對visio的流程圖不起作用

简单测试了一下,好象是可以的
只有本站会员才能查看附件,请 登录

只有本站会员才能查看附件,请 登录

test.prg
程序代码:

cDefPath = ADDBS(JUSTPATH(SYS(16)))
SET DEFAULT TO (cDefPath)
DECLARE LONG LCMapString IN Kernel32 LONG, LONG, STRING, LONG, STRING@, LONG
oVisio = Createobject("Visio.Application")
oVisio.Visible = 0
oVisio.Documents.Open(cDefPath+"1生產運作流程圖2018-07-12.vsd")
FOR EACH cell IN oVisio.ActiveWindow.Page.Shapes
  cell.Text = TtoS(cell.Text)
ENDFOR
oVisio.Visible = 1
RETURN

FUNCTION TtoS(cSource)
    LOCAL nLen
    nLen = LEN(cSource)
    cDest = SPACE(nLen)
    LCMapString(0x800, 0x2000000, @cSource, nLen, @cDest, nLen)
    RETURN cDest
ENDFUNC

FUNCTION StoT(cSource)
    LOCAL nLen
    nLen = LEN(cSource)
    cDest = SPACE(nLen)
    LCMapString(0x800, 0x4000000, @cSource, nLen, @cDest, nLen)
    RETURN cDest
ENDFUNC
#7
ken32382021-12-12 04:32
以下是引用吹水佬在2021-12-11 21:57:43的发言:


简单测试了一下,好象是可以的


test.prg

cDefPath = ADDBS(JUSTPATH(SYS(16)))
SET DEFAULT TO (cDefPath)
DECLARE LONG LCMapString IN Kernel32 LONG, LONG, STRING, LONG, STRING@, LONG
oVisio = Createobject("Visio.Application")
oVisio.Visible = 0
oVisio.Documents.Open(cDefPath+"1生產運作流程圖2018-07-12.vsd")
FOR EACH cell IN oVisio.ActiveWindow.Page.Shapes
  cell.Text = TtoS(cell.Text)
ENDFOR
oVisio.Visible = 1
RETURN

FUNCTION TtoS(cSource)
    LOCAL nLen
    nLen = LEN(cSource)
    cDest = SPACE(nLen)
    LCMapString(0x800, 0x2000000, @cSource, nLen, @cDest, nLen)
    RETURN cDest
ENDFUNC

FUNCTION StoT(cSource)
    LOCAL nLen
    nLen = LEN(cSource)
    cDest = SPACE(nLen)
    LCMapString(0x800, 0x4000000, @cSource, nLen, @cDest, nLen)
    RETURN cDest
ENDFUNC

非常感謝吹版指點!經測試,可用.
因為有的文件會有2頁以上,經測試,只能轉換當前頁,
嘗試加了2行代碼,運行顯示可循環讀取所有頁面,但都只是轉換了當前頁,久思不能解,還請吹版再指教怎樣改,謝謝!

cDefPath = ADDBS(JUSTPATH(SYS(16)))
SET DEFAULT TO (cDefPath)
DECLARE LONG LCMapString IN Kernel32 LONG, LONG, STRING, LONG, STRING@, LONG
oVisio = Createobject("Visio.Application")
oVisio.Visible = 0
oVisio.Documents.Open(cDefPath+"1生產運作流程圖2018-07-12.vsd")

 FOR EACH oVisioPage IN ovisio.ActiveDocument.Pages&&本人加的代碼
          ?oVisioPage.name &&此句顯示了頁-1,頁-2,直到所有頁

     FOR EACH cell IN oVisio.ActiveWindow.Page.Shapes
         cell.Text = TtoS(cell.Text)
     ENDFOR
     oVisio.Visible = 1

ENDFOR&&本人加的代碼
RETURN

FUNCTION TtoS(cSource)
    LOCAL nLen
    nLen = LEN(cSource)
    cDest = SPACE(nLen)
    LCMapString(0x800, 0x2000000, @cSource, nLen, @cDest, nLen)
    RETURN cDest
ENDFUNC

FUNCTION StoT(cSource)
    LOCAL nLen
    nLen = LEN(cSource)
    cDest = SPACE(nLen)
    LCMapString(0x800, 0x4000000, @cSource, nLen, @cDest, nLen)
    RETURN cDest
ENDFUNC


[此贴子已经被作者于2021-12-12 04:34编辑过]

#8
吹水佬2021-12-12 09:26
回复 7楼 ken3238
程序代码:
FOR EACH oVisioPage IN ovisio.ActiveDocument.Pages
    FOR EACH cell IN oVisioPage.Shapes
        cell.Text = TtoS(cell.Text)
    ENDFOR
ENDFOR
#9
ken32382021-12-12 09:49
回复 8楼 吹水佬
謝謝版主,我再試下
#10
ken32382021-12-12 11:57
回复 8楼 吹水佬
版主:問題解決了!!非常感謝!!!
1