[求助] InsertPic excel 2007問題

hktemp

2003運行完全沒問題的
但2007就運行不能了......
睇過應該是以下那句出了問題
各大師有沒有方法可以在2007運行呢

thx

InsertPic (ThisWorkbook.Path & "\" & .Cells(i, 2)), Worksheets("DETAIL").Cells(i, 6), ActiveCell

[ 本帖最后由 hktemp 于 2008-7-10 19:17 编辑 ]

hktemp

各位大大真的是沒有方法嗎??

crdotlin

[將網頁中的圖片插入工作表] 這個問題在目前之所以成為問題，是因為原本在EXCEL 2003時有一個Worksheet.Pictures.Insert的方法可以將網頁中的圖片直接插入工作表中，但現在EXCEL 2007卻不作用了。有人認為這是2007的臭蟲，紛紛向MS反應。至目前為止尚無更新或補丁出現。
台期指05 走勢圖的URL為"http://tw.futures.finance.yahoo.com/future/png/F-FITX200805.png"，要將它插入工作表若使用EXCEL 2003可以嘗試下面的程式碼
Public nextRun As Date      '下次執行的時間變數

'使用在2003版本
Sub getIdxMapxx()
Dim temPic As Picture   'Pictrue物件變數
With ActiveSheet        '對於現行工作表
    .Range("c6").Select     '設定插入圖片位置
    On Error Resume Next
    .Pictures("IdxMap").Delete      '刪除先前之圖
    On Error GoTo 0
End With
'使用Pictures.Insert來插入網頁中的圖片
Set temPic = ActiveSheet.Pictures.Insert("http://tw.futures.finance.yahoo.com/future/png/F-FITX200805.png")
'設定圖片名稱
temPic.Name = "IdxMap"
'選定A1儲存格，離開圖片
ActiveSheet.Range("a1").Select
'下次執行的時間為1分鐘後
nextRun = Now + 1 / 1440#
'排定下次執行
Application.OnTime nextRun, "getIdxMapxx"
End Sub

'清除先前設定執行getIdxMapxx的程序
Sub stopUpdatexx()
    On Error Resume Next
    Application.OnTime nextRun, "getIdxMapxx", Schedule:=False
End Sub
因為我目前使用EXCEL 2007，上面程式沒有測試。若有問題請再提出，以便修正。
上面的問題如果在EXCEL 2007應該如何做呢？這讓我又想到萬能的Application.Sendkeys了。因為 [插入] [圖片] 後出現的對話框中，若我們在檔案名稱編輯框內輸入URL位址，仍然可以將網頁的圖片插入工作表中。沒想到在測試過程中狀況百，原因為EXCEL 2007之Application.Sendkeys一直無法確實的將URL字串傳送到檔案名稱的框框，顯然Application.Sendkeys在2007變得難以控制了。因此下面的程式碼出現了一些莫名其妙的敘述，各位請勿見怪。
Public nextRun As Date      '下次執行的時間變數

'2007版本使用，
'Excel視窗必須正在使用中，即現行視窗
'在任何輸入法下都需要在 [英數] 模式
Sub getIdxMap()
Dim i As Long
'設定圖片位置並刪除先前圖片
With ActiveSheet
    .Range("c6").Select
    On Error Resume Next
    .Shapes("IdxMap").Delete
    On Error GoTo 0
End With
With Application
'////////
'這中間的敘述不知所云
'只為了調整節奏，讓URL字串順利送到 [檔案名稱] 的編輯框中
    For i = 1 To 60
    .SendKeys "   "
    Next
    .SendKeys "{clear}"
'////////
'送出URL字串，並按下 {ENTER]} 鍵
    .SendKeys "http://tw.futures.finance.yahoo.com/future/png/F-FITX200805.png~"
'顯示 [插入圖片] 對話框
    .Dialogs(xlDialogInsertPicture).Show
End With
'設定圖片名稱
Selection.Name = "IdxMap"
'選定A1儲存格，離開圖片
ActiveSheet.Range("a1").Select
'下次執行的時間為1分鐘後
nextRun = Now + 1 / 1440#
'排定下次執行
Application.OnTime nextRun, "getIdxMap"
End Sub

'清除先前設定執行getIdxMap的程序
Sub stopUpdate()
    On Error Resume Next
    Application.OnTime nextRun, "getIdxMap", Schedule:=False
End Sub

有兩點要聲明，測試上述程序時
1. EXCEL視窗必須是現行的視窗，即作用中的視窗。
2. 不管是何種輸入法，都需在 [英數] 模式上。

我的作業環境：Vista, Office 2007
InsertPictureFmURL.zip

將網頁中的圖片插入工作表(Insert a picture to worksheet from URL)

若是檔案，將URL字串改為檔案路徑即可。

[ 本帖最后由 crdotlin 于 2008-7-18 11:34 编辑 ]

hktemp

增加圖片可以了
但以下的inpic function還未能在2007運行哦
大師怎辨好哦?

Function InsertPic(ByVal picPath As String, ByVal picName As String, ByVal cel As Range)
Dim picFactor As Single, celFactor As Single
Application.ScreenUpdating = False
On Error GoTo abc
    With cel.Parent.Pictures.Insert(picPath)
         .Name = picName
         picFactor = .Width / .Height
         celFactor = cel.Width / cel.Height
         
         If picFactor > celFactor Then
            .Width = cel.Width
            .Height = .Width / picFactor
            .Top = cel.Top + (cel.Height - .Height) / 2
            .Left = cel.Left
        
         Else
            .Height = cel.Height
            .Width = .Height * picFactor
            .Top = cel.Top
            .Left = cel.Left + (cel.Width - .Width) / 2

         End If
    End With
    Exit Function
   
abc:   '  With Sheets("Database")
       '  MsgBox "Can Not Find The Image : " & picName
         Exit Function
      '   End With
   
   
End Function

Emily

Sub InsertPictures()

    InsertPicture "C:\playstation.jpg", Range("C2"), 0.5
   
End Sub

Sub InsertPicture(ByVal PicturePath As String, _
                  ByVal TargetRange As Range, _
                  ByVal Scaling As Double)

    Dim NewImage As ShapeRange
   
    If Len(Dir(PicturePath)) > 0 Then
        Set NewImage = TargetRange.Parent.Pictures.Insert(PicturePath).ShapeRange
        NewImage.Left = TargetRange.Left
        NewImage.Top = TargetRange.Top
        NewImage.ScaleWidth Scaling, msoFalse, msoScaleFromTopLeft
        NewImage.ScaleHeight Scaling, msoFalse, msoScaleFromTopLeft
    End If

End Sub

crdotlin

原帖由 Emily 于 2008-7-19 11:44 发表
Sub InsertPictures()

    InsertPicture "C:\playstation.jpg", Range("C2"), 0.5
   
End Sub

Sub InsertPicture(ByVal PicturePath As String, _
                  ByVal TargetRange As Range, _
   ...

嗨！Emily，
忘記對於Local圖檔還是可以用。回復的好呀！

hktemp

emily 以下picture 不能做到在一cells內最大化圖象的效果哦

Sub InsertPicture(ByVal PicturePath As String, _
                  ByVal TargetRange As Range, _
                  ByVal Scaling As Double)

    Dim NewImage As ShapeRange
   
    If Len(Dir(PicturePath)) > 0 Then
        Set NewImage = TargetRange.Parent.Pictures.Insert(PicturePath).ShapeRange
        NewImage.Left = TargetRange.Left
        NewImage.Top = TargetRange.Top
        NewImage.ScaleWidth Scaling, msoFalse, msoScaleFromTopLeft
        NewImage.ScaleHeight Scaling, msoFalse, msoScaleFromTopLeft
    End If

End Sub

hktemp

用回原來的就可以了...........

原來一開始是　file search 問題

現在改用以下ｃｏｄｅ．就能在2007 運行了
不過想問怎樣修改才能只ｌｉｓｔ出　ｊｐｇ的ｌｉｓｔ呢

Sub testit()
    myvar = FileList(ThisWorkbook.Path)
    If TypeName(myvar) <> "Boolean" Then
        For i = LBound(myvar) To UBound(myvar)
        
        n = n + 1
        Worksheets("DETAIL").Cells(n, 2) = myvar(i)
        
        
            Debug.Print myvar(i)
        Next
    Else
         MsgBox "No files found"
    End If
End Sub

Function FileList(fldr As String, Optional fltr As String = "*.*") As Variant
    Dim sTemp As String, sHldr As String
    If Right$(fldr, 1) <> "\" Then fldr = fldr & "\"
    sTemp = Dir(fldr & fltr)
    If sTemp = "" Then
        FileList = False
        Exit Function
    End If
    Do
        sHldr = Dir
        If sHldr = "" Then Exit Do
        sTemp = sTemp & "|" & sHldr
     Loop
    FileList = Split(sTemp, "|")
End Function

Emily

原帖由 hktemp 于 2008-7-19 14:28 发表
emily 以下picture 不能做到在一cells內最大化圖象的效果哦

Sub InsertPicture(ByVal PicturePath As String, _
                  ByVal TargetRange As Range, _
                  ByVal Scaling As Double) ...

Sub InsertPictures()

    InsertPicture "C:\playstation.jpg", Range("C2"), 0.5 ' 這是 picture 的倍數 , set 1 就可以啦
   
End Sub

Sub InsertPicture(ByVal PicturePath As String, _
                  ByVal TargetRange As Range, _
                  ByVal Scaling As Double)

HOmT398

To Emily
题外话，发现您的发帖的关键字里有区别的颜色，是用了什么工具？好奇一下。

hktemp

emily
可能是我表能不好......
我想說的是在圖在一cells的范圖內做到最大化
不緊要...我原先的code還是可行的

另一問題想問
我用了以下的code 只可以list 到folder內的所有file的名稱
但是如果我只想list出 jpg的圖案,有可行的方法嗎??

第二個問題就是剛發現的
ThisWorkbook.Path 在excel 2007 內是不是不support 有中文字元的?

Thanks


Sub testit()
    myvar = FileList(ThisWorkbook.Path)
    If TypeName(myvar) <> "Boolean" Then
        For i = LBound(myvar) To UBound(myvar)
        
        n = n + 1
        Worksheets("DETAIL").Cells(n, 2) = myvar(i)
        
        
            Debug.Print myvar(i)
        Next
    Else
         MsgBox "No files found"
    End If
End Sub

Function FileList(fldr As String, Optional fltr As String = "*.*") As Variant
    Dim sTemp As String, sHldr As String
    If Right$(fldr, 1) <> "\" Then fldr = fldr & "\"
    sTemp = Dir(fldr & fltr)
    If sTemp = "" Then
        FileList = False
        Exit Function
    End If
    Do
        sHldr = Dir
        If sHldr = "" Then Exit Do
        sTemp = sTemp & "|" & sHldr
     Loop
    FileList = Split(sTemp, "|")
End Function

crdotlin

原帖由 HOmT398 于 2008-7-20 01:34 发表
To Emily
题外话，发现您的发帖的关键字里有区别的颜色，是用了什么工具？好奇一下。

看起來是chijanzen的那個東西，我則是用

當載入後在工具選項或右鍵選項都有如下紅圈項目可用

Emily

Please read
http://www.ozgrid.com/forum/showthread.php?t=71409

Dir function
http://www.excel-it.com/Excel%202007/2007_filesearch.htm

Emily

原帖由 HOmT398 于 2008-7-20 01:34 发表
To Emily
题外话，发现您的发帖的关键字里有区别的颜色，是用了什么工具？好奇一下。

對, 是 chijanzen , VBAToHtml

chijanzen 網頁沒有了 ....

hktemp

多謝各位.....己完成了.

HOmT398

To, Crdotlin
记得winland也分享过，http://www.mrexcel.com/vbaddin.shtml，没去用，差点忘了。

To, Emily
将您分享的工具转换成简体版的了，谢谢